diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/typecheck/FamInst.hs (renamed from compiler/typecheck/FamInst.lhs) | 67 | ||||
| -rw-r--r-- | compiler/typecheck/FunDeps.hs (renamed from compiler/typecheck/FunDeps.lhs) | 65 | ||||
| -rw-r--r-- | compiler/typecheck/Inst.hs (renamed from compiler/typecheck/Inst.lhs) | 116 | ||||
| -rw-r--r-- | compiler/typecheck/TcAnnotations.hs (renamed from compiler/typecheck/TcAnnotations.lhs) | 14 | ||||
| -rw-r--r-- | compiler/typecheck/TcArrows.hs (renamed from compiler/typecheck/TcArrows.lhs) | 112 | ||||
| -rw-r--r-- | compiler/typecheck/TcBinds.hs (renamed from compiler/typecheck/TcBinds.lhs) | 76 | ||||
| -rw-r--r-- | compiler/typecheck/TcCanonical.hs (renamed from compiler/typecheck/TcCanonical.lhs) | 139 | ||||
| -rw-r--r-- | compiler/typecheck/TcClassDcl.hs (renamed from compiler/typecheck/TcClassDcl.lhs) | 51 | ||||
| -rw-r--r-- | compiler/typecheck/TcDefaults.hs (renamed from compiler/typecheck/TcDefaults.lhs) | 14 | ||||
| -rw-r--r-- | compiler/typecheck/TcDeriv.hs (renamed from compiler/typecheck/TcDeriv.lhs) | 132 | ||||
| -rw-r--r-- | compiler/typecheck/TcEnv.hs (renamed from compiler/typecheck/TcEnv.lhs) | 208 | ||||
| -rw-r--r-- | compiler/typecheck/TcEnv.hs-boot | 6 | ||||
| -rw-r--r-- | compiler/typecheck/TcEnv.lhs-boot | 4 | ||||
| -rw-r--r-- | compiler/typecheck/TcErrors.hs (renamed from compiler/typecheck/TcErrors.lhs) | 79 | ||||
| -rw-r--r-- | compiler/typecheck/TcEvidence.hs (renamed from compiler/typecheck/TcEvidence.lhs) | 74 | ||||
| -rw-r--r-- | compiler/typecheck/TcExpr.hs (renamed from compiler/typecheck/TcExpr.lhs) | 210 | ||||
| -rw-r--r-- | compiler/typecheck/TcExpr.hs-boot (renamed from compiler/typecheck/TcExpr.lhs-boot) | 8 | ||||
| -rw-r--r-- | compiler/typecheck/TcFlatten.hs (renamed from compiler/typecheck/TcFlatten.lhs) | 98 | ||||
| -rw-r--r-- | compiler/typecheck/TcForeign.hs (renamed from compiler/typecheck/TcForeign.lhs) | 95 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenDeriv.hs (renamed from compiler/typecheck/TcGenDeriv.lhs) | 231 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenGenerics.hs (renamed from compiler/typecheck/TcGenGenerics.lhs) | 47 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsSyn.hs (renamed from compiler/typecheck/TcHsSyn.lhs) | 121 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsType.hs (renamed from compiler/typecheck/TcHsType.lhs) | 117 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.hs (renamed from compiler/typecheck/TcInstDcls.lhs) | 90 | ||||
| -rw-r--r-- | compiler/typecheck/TcInteract.hs (renamed from compiler/typecheck/TcInteract.lhs) | 76 | ||||
| -rw-r--r-- | compiler/typecheck/TcMType.hs (renamed from compiler/typecheck/TcMType.lhs) | 180 | ||||
| -rw-r--r-- | compiler/typecheck/TcMatches.hs (renamed from compiler/typecheck/TcMatches.lhs) | 86 | ||||
| -rw-r--r-- | compiler/typecheck/TcMatches.hs-boot (renamed from compiler/typecheck/TcMatches.lhs-boot) | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcPat.hs (renamed from compiler/typecheck/TcPat.lhs) | 86 | ||||
| -rw-r--r-- | compiler/typecheck/TcPatSyn.hs (renamed from compiler/typecheck/TcPatSyn.lhs) | 63 | ||||
| -rw-r--r-- | compiler/typecheck/TcPatSyn.hs-boot (renamed from compiler/typecheck/TcPatSyn.lhs-boot) | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.hs (renamed from compiler/typecheck/TcRnDriver.lhs) | 202 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.hs (renamed from compiler/typecheck/TcRnMonad.lhs) | 264 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs (renamed from compiler/typecheck/TcRnTypes.lhs) | 250 | ||||
| -rw-r--r-- | compiler/typecheck/TcRules.hs (renamed from compiler/typecheck/TcRules.lhs) | 16 | ||||
| -rw-r--r-- | compiler/typecheck/TcSMonad.hs (renamed from compiler/typecheck/TcSMonad.lhs) | 166 | ||||
| -rw-r--r-- | compiler/typecheck/TcSimplify.hs (renamed from compiler/typecheck/TcSimplify.lhs) | 88 | ||||
| -rw-r--r-- | compiler/typecheck/TcSplice.hs (renamed from compiler/typecheck/TcSplice.lhs) | 167 | ||||
| -rw-r--r-- | compiler/typecheck/TcSplice.hs-boot (renamed from compiler/typecheck/TcSplice.lhs-boot) | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs (renamed from compiler/typecheck/TcTyClsDecls.lhs) | 140 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyDecls.hs (renamed from compiler/typecheck/TcTyDecls.lhs) | 80 | ||||
| -rw-r--r-- | compiler/typecheck/TcType.hs (renamed from compiler/typecheck/TcType.lhs) | 215 | ||||
| -rw-r--r-- | compiler/typecheck/TcType.hs-boot (renamed from compiler/typecheck/TcType.lhs-boot) | 4 | ||||
| -rw-r--r-- | compiler/typecheck/TcUnify.hs (renamed from compiler/typecheck/TcUnify.lhs) | 113 | ||||
| -rw-r--r-- | compiler/typecheck/TcUnify.hs-boot (renamed from compiler/typecheck/TcUnify.lhs-boot) | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcValidity.hs (renamed from compiler/typecheck/TcValidity.lhs) | 258 |
46 files changed, 2118 insertions, 2518 deletions
diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.hs index 08b7e9d3f8..3a16ff0218 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.hs @@ -1,6 +1,5 @@ -The @FamInst@ type: family instance heads +-- The @FamInst@ type: family instance heads -\begin{code} {-# LANGUAGE CPP, GADTs #-} module FamInst ( @@ -37,15 +36,15 @@ import Data.Map (Map) import qualified Data.Map as Map #include "HsVersions.h" -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Making a FamInst -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- All type variables in a FamInst must be fresh. This function -- creates the fresh variables and applies the necessary substitution -- It is defined here to avoid a dependency from FamInstEnv on the monad @@ -67,14 +66,13 @@ newFamInst flavor axiom@(CoAxiom { co_ax_branches = FirstBranch branch , fi_tys = substTys subst lhs , fi_rhs = substTy subst rhs , fi_axiom = axiom }) } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Optimised overlap checking for family instances -%* * -%************************************************************************ +* * +************************************************************************ For any two family instance modules that we import directly or indirectly, we check whether the instances in the two modules are consistent, *unless* we can @@ -96,8 +94,8 @@ modules where both modules occur in the `HscTypes.dep_finsts' set (of the `HscTypes.Dependencies') of one of our directly imported modules must have already been checked. Everything else, we check now. (So that we can be certain that the modules in our `HscTypes.dep_finsts' are consistent.) +-} -\begin{code} -- The optimisation of overlap tests is based on determining pairs of modules -- whose family instances need to be checked for consistency. -- @@ -173,13 +171,13 @@ getFamInsts hpt_fam_insts mod lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } where doc = ppr mod <+> ptext (sLit "is a family-instance module") -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Lookup -%* * -%************************************************************************ +* * +************************************************************************ Look up the instance tycon of a family instance. @@ -200,8 +198,8 @@ then we have a coercion (ie, type instance of family instance coercion) :Co:R42T Int :: T [Int] ~ :R42T Int which implies that :R42T was declared as 'data instance T [a]'. +-} -\begin{code} tcLookupFamInst :: FamInstEnvs -> TyCon -> [Type] -> Maybe FamInstMatch tcLookupFamInst fam_envs tycon tys | not (isOpenFamilyTyCon tycon) @@ -256,16 +254,15 @@ tcInstNewTyConTF_maybe fam_envs ty = Just (rep_tc, inner_ty, fam_co `mkTcTransCo` nt_co) | otherwise = Nothing -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Extending the family instance environment -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- Add new locally-defined family instances tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a tcExtendLocalFamInstEnv fam_insts thing_inside @@ -312,18 +309,18 @@ addLocalFamInst (home_fie, my_fis) fam_inst return (home_fie'', fam_inst : my_fis') else return (home_fie, my_fis) } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Checking an instance against conflicts with an instance env -%* * -%************************************************************************ +* * +************************************************************************ Check whether a single family instance conflicts with those in two instance environments (one for the EPS and one for the HPT). +-} -\begin{code} checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool checkForConflicts inst_envs fam_inst = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst @@ -366,5 +363,3 @@ tcGetFamInstEnvs :: TcM FamInstEnvs tcGetFamInstEnvs = do { eps <- getEps; env <- getGblEnv ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } -\end{code} - diff --git a/compiler/typecheck/FunDeps.lhs b/compiler/typecheck/FunDeps.hs index e636d5b533..65767faded 100644 --- a/compiler/typecheck/FunDeps.lhs +++ b/compiler/typecheck/FunDeps.hs @@ -1,13 +1,13 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 2000 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 2000 + FunDeps - functional dependencies It's better to read it as: "if we know these, then we're going to know these" +-} -\begin{code} {-# LANGUAGE CPP #-} module FunDeps ( @@ -36,14 +36,13 @@ import FastString import Data.List ( nubBy ) import Data.Maybe ( isJust ) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Generate equations from functional dependencies} -%* * -%************************************************************************ +* * +************************************************************************ Each functional dependency with one variable in the RHS is responsible @@ -94,8 +93,8 @@ This means that the template variable would be instantiated to different unification variables when producing the FD constraints. Finally, the position parameters will help us rewrite the wanted constraint ``on the spot'' +-} -\begin{code} data Equation loc = FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars to fresh unification vars , fd_eqs :: [FDEq] -- and then make these equal @@ -109,8 +108,8 @@ data FDEq = FDEq { fd_pos :: Int -- We use '0' for the first position instance Outputable FDEq where ppr (FDEq { fd_pos = p, fd_ty_left = tyl, fd_ty_right = tyr }) = parens (int p <> comma <+> ppr tyl <> comma <+> ppr tyr) -\end{code} +{- Given a bunch of predicates that must hold, such as C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5 @@ -137,10 +136,8 @@ NOTA BENE: * The equations unify types that are not already equal. So there is no effect iff the result of improve is empty +-} - - -\begin{code} instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type -- A simpler version of instFD_WithPos to be used in checking instance coverage etc. instFD (ls,rs) tvs tys @@ -340,14 +337,13 @@ checkClsFD fd clas_tvs (ltys1, rtys1) = instFD fd clas_tvs tys_inst (ltys2, irs2) = instFD_WithPos fd clas_tvs tys_actual -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * The Coverage condition for instance declarations -%* * -%************************************************************************ +* * +************************************************************************ Note [Coverage condition] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -376,8 +372,8 @@ But it is a mistake to accept the instance because then this defn: f = \ b x y -> if b then x .*. [y] else y makes instance inference go into a loop, because it requires the constraint Mul a [b] b +-} -\begin{code} checkInstCoverage :: Bool -- Be liberal -> Class -> [PredType] -> [Type] -> Validity @@ -420,8 +416,8 @@ checkInstCoverage be_liberal clas theta inst_taus <+> pprQuotedList rs ] , ppWhen (not be_liberal && liberal_ok) $ ptext (sLit "Using UndecidableInstances might help") ] -\end{code} +{- Note [Closing over kinds in coverage] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have a fundep (a::k) -> b @@ -453,10 +449,10 @@ assumption `t1 ~ t2`, then we use the fact that if we know `t1` we also know `t2` and the other way. eg oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x} -oclose is used (only) when checking the coverage condition for +oclose is used (only) when checking the coverage condition for an instance declaration +-} -\begin{code} oclose :: [PredType] -> TyVarSet -> TyVarSet -- See Note [The liberal coverage condition] oclose preds fixed_tvs @@ -487,13 +483,13 @@ oclose preds fixed_tvs EqPred t1 t2 -> [([t1],[t2]), ([t2],[t1])] TuplePred ts -> concatMap determined ts _ -> [] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Check that a new instance decl is OK wrt fundeps -%* * -%************************************************************************ +* * +************************************************************************ Here is the bad case: class C a b | a->b where ... @@ -519,9 +515,8 @@ The instance decls don't overlap, because the third parameter keeps them separate. But we want to make sure that given any constraint D s1 s2 s3 if s1 matches +-} - -\begin{code} checkFunDeps :: InstEnvs -> ClsInst -> Maybe [ClsInst] -- Nothing <=> ok -- Just dfs <=> conflict with dfs @@ -569,7 +564,3 @@ trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs where select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc | otherwise = Nothing -\end{code} - - - diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.hs index c737d627ca..a059c5030c 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + The @Inst@ type: dictionaries or method instances +-} -\begin{code} {-# LANGUAGE CPP #-} module Inst ( @@ -58,17 +58,15 @@ import Util import Outputable import Control.Monad( unless ) import Data.Maybe( isJust ) -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * Emitting constraints -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar] emitWanteds origin theta = mapM (emitWanted origin) theta @@ -101,14 +99,13 @@ newMethodFromName origin name inst_ty ; wrap <- ASSERT( null rest && isSingleton theta ) instCall origin [inst_ty] (substTheta subst theta) ; return (mkHsWrap wrap (HsVar id)) } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Deep instantiation and skolemisation -%* * -%************************************************************************ +* * +************************************************************************ Note [Deep skolemisation] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -134,9 +131,8 @@ In general, ToDo: this eta-abstraction plays fast and loose with termination, because it can introduce extra lambdas. Maybe add a `seq` to fix this +-} - -\begin{code} deeplySkolemise :: TcSigmaType -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType) @@ -185,16 +181,15 @@ deeplyInstantiate orig ty mkFunTys arg_tys rho2) } | otherwise = return (idHsWrapper, ty) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Instantiating a call -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} ---------------- instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper -- Instantiate the constraints of a call @@ -235,20 +230,20 @@ instStupidTheta :: CtOrigin -> TcThetaType -> TcM () instStupidTheta orig theta = do { _co <- instCallConstraints orig theta -- Discard the coercion ; return () } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Literals -%* * -%************************************************************************ +* * +************************************************************************ In newOverloadedLit we convert directly to an Int or Integer if we know that's what we want. This may save some time, by not temporarily generating overloaded literals, but it won't catch all cases (the rest are caught in lookupInst). +-} -\begin{code} newOverloadedLit :: CtOrigin -> HsOverLit Name -> TcRhoType @@ -298,18 +293,15 @@ mkOverLit (HsFractional r) ; return (HsRat r rat_ty) } mkOverLit (HsIsString src s) = return (HsString src s) -\end{code} - - - -%************************************************************************ -%* * +{- +************************************************************************ +* * Re-mappable syntax Used only for arrow syntax -- find a way to nuke this -%* * -%************************************************************************ +* * +************************************************************************ Suppose we are doing the -XRebindableSyntax thing, and we encounter a do-expression. We have to find (>>) in the current environment, which is @@ -332,8 +324,8 @@ the expected type. In fact tcSyntaxName just generates the RHS for then72, because we only want an actual binding in the do-expression case. For literals, we can just use the expression inline. +-} -\begin{code} tcSyntaxName :: CtOrigin -> TcType -- Type to instantiate it at -> (Name, HsExpr Name) -- (Standard name, user name) @@ -374,16 +366,15 @@ syntaxNameCtxt name orig ty tidy_env <+> ppr (tidyType tidy_env ty)) , nest 2 (pprArisingAt inst_loc) ] ; return (tidy_env, msg) } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Instances -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag getOverlapFlag overlap_mode = do { dflags <- getDynFlags @@ -492,8 +483,8 @@ addLocalInst (home_ie, my_insts) ispec dupInstErr ispec (head dups) ; return (extendInstEnv home_ie' ispec, ispec:my_insts') } -\end{code} +{- Note [Signature files and type class instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Instances in signature files do not have an effect when compiling: @@ -539,13 +530,13 @@ See also Note [Signature lazy interface loading]. We can't rely on this, however, since sometimes we'll have spurious type class instances in the EPS, see #9422 (sigof02dm) -%************************************************************************ -%* * +************************************************************************ +* * Errors and tracing -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} traceDFuns :: [ClsInst] -> TcRn () traceDFuns ispecs = traceTc "Adding instances:" (vcat (map pp ispecs)) @@ -573,15 +564,15 @@ addClsInstsErr herald ispecs -- The sortWith just arranges that instances are dislayed in order -- of source location, which reduced wobbling in error messages, -- and is better for users -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Simple functions over evidence variables -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} ---------------- Getting free tyvars ------------------------- tyVarsOfCt :: Ct -> TcTyVarSet tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv @@ -610,4 +601,3 @@ tyVarsOfImplic (Implic { ic_skols = skols tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet -\end{code} diff --git a/compiler/typecheck/TcAnnotations.lhs b/compiler/typecheck/TcAnnotations.hs index cbd19cf8f3..ca04569f28 100644 --- a/compiler/typecheck/TcAnnotations.lhs +++ b/compiler/typecheck/TcAnnotations.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1993-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + \section[TcAnnotations]{Typechecking annotations} +-} -\begin{code} {-# LANGUAGE CPP #-} module TcAnnotations ( tcAnnotations, annCtxt ) where @@ -22,9 +22,6 @@ import SrcLoc import Outputable import FastString -\end{code} - -\begin{code} #ifndef GHCI @@ -61,4 +58,3 @@ annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod annCtxt :: OutputableBndr id => AnnDecl id -> SDoc annCtxt ann = hang (ptext (sLit "In the annotation:")) 2 (ppr ann) -\end{code}
\ No newline at end of file diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.hs index a879e16e78..f1546b4e42 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Typecheck arrow notation +-} -\begin{code} {-# LANGUAGE RankNTypes #-} module TcArrows ( tcProc ) where @@ -27,7 +27,7 @@ import Inst import Name import Coercion ( Role(..) ) import TysWiredIn -import VarSet +import VarSet import TysPrim import BasicTypes( Arity ) import SrcLoc @@ -36,14 +36,14 @@ import FastString import Util import Control.Monad -\end{code} +{- Note [Arrow overivew] ~~~~~~~~~~~~~~~~~~~~~ Here's a summary of arrows and how they typecheck. First, here's a cut-down syntax: - expr ::= .... + expr ::= .... | proc pat cmd cmd ::= cmd exp -- Arrow application @@ -57,7 +57,7 @@ a cut-down syntax: | (type, carg_type) Note that - * The 'exp' in an arrow form can mention only + * The 'exp' in an arrow form can mention only "arrow-local" variables * An "arrow-local" variable is bound by an enclosing @@ -71,38 +71,37 @@ Note that (| e1 <<< arr snd |) e2 -%************************************************************************ -%* * - Proc -%* * -%************************************************************************ +************************************************************************ +* * + Proc +* * +************************************************************************ +-} -\begin{code} tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr -> TcRhoType -- Expected type of whole proc expression -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion) tcProc pat cmd exp_ty = newArrowScope $ - do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty + do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 ; let cmd_env = CmdEnv { cmd_arr = arr_ty } ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ tcCmdTop cmd_env cmd (unitTy, res_ty) ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcNomReflCo res_ty)) ; return (pat', cmd', res_co) } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Commands -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} --- See Note [Arrow overview] -type CmdType = (CmdArgType, TcTauType) -- cmd_type +-- See Note [Arrow overview] +type CmdType = (CmdArgType, TcTauType) -- cmd_type type CmdArgType = TcTauType -- carg_type, a nested tuple data CmdEnv @@ -114,7 +113,7 @@ mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] --------------------------------------- -tcCmdTop :: CmdEnv +tcCmdTop :: CmdEnv -> LHsCmdTop Name -> CmdType -> TcM (LHsCmdTop TcId) @@ -145,7 +144,7 @@ tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do - (scrut', scrut_ty) <- tcInferRho scrut + (scrut', scrut_ty) <- tcInferRho scrut matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty return (HsCmdCase scrut' matches') where @@ -206,8 +205,8 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } where -- Before type-checking f, use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope -- inside f. In the higher-order case (-<<), they are. select_arrow_scope tc = case ho_app of HsHigherOrderApp -> tc @@ -235,7 +234,7 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) -- ------------------------------ -- D;G |-a (\x.cmd) : (t,stk) --> res -tc_cmd env +tc_cmd env (HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))], mg_origin = origin })) (cmd_stk, res_ty) = addErrCtxt (pprMatchInCtxt match_ctxt match) $ @@ -271,7 +270,7 @@ tc_cmd env tc_cmd env (HsCmdDo stmts _) (cmd_stk, res_ty) = do { co <- unifyType unitTy cmd_stk -- Expecting empty argument stack - ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty + ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) } @@ -289,7 +288,7 @@ tc_cmd env (HsCmdDo stmts _) (cmd_stk, res_ty) -- ---------------------------------------------- -- D; G |-a (| e c1 ... cn |) : stk --> t -tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args ; let e_ty = mkForAllTy alphaTyVar $ -- We use alphaTyVar for 'w' @@ -313,27 +312,26 @@ tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- This is where expressions that aren't commands get rejected tc_cmd _ cmd _ - = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), + = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), ptext (sLit "was found where an arrow command was expected")]) matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType) -matchExpectedCmdArgs 0 ty +matchExpectedCmdArgs 0 ty = return (mkTcNomReflCo ty, [], ty) matchExpectedCmdArgs n ty - = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty + = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Stmts -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -------------------------------- -- Mdo-notation -- The distinctive features here are @@ -369,7 +367,7 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names zipWithM tcCheckId tup_names tup_elt_tys ; thing <- thing_inside res_ty - -- NB: The rec_ids for the recursive things + -- NB: The rec_ids for the recursive things -- already scope over this part. This binding may shadow -- some of them with polymorphic things with the same Name -- (see note [RecStmt] in HsExpr) @@ -396,32 +394,28 @@ tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType) tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcCmd env rhs (unitTy, ty) ; return (rhs', ty) } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Helpers -%* * -%************************************************************************ - +* * +************************************************************************ +-} -\begin{code} mkPairTy :: Type -> Type -> Type mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] arrowTyConKind :: Kind -- *->*->* arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Errors -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} cmdCtxt :: HsCmd Name -> SDoc cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd -\end{code} diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.hs index 05fed32f71..79f630ef79 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + \section[TcBinds]{TcBinds} +-} -\begin{code} {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, @@ -62,14 +62,13 @@ import Control.Monad import Data.List (partition) #include "HsVersions.h" -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Type-checking bindings} -%* * -%************************************************************************ +* * +************************************************************************ @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because it needs to know something about the {\em usage} of the things bound, @@ -154,8 +153,8 @@ Then we get fm = \ys:[a] -> ...fm... in fm +-} -\begin{code} tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv) -- The TcGblEnv contains the new tcg_binds and tcg_spects -- The TcLclEnv has an extended type envt for the new bindings @@ -257,9 +256,7 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside Just (_,_,ax) -> HsWrap $ mkWpCast $ mkTcSymCo $ mkTcUnbranchedAxInstCo Representational ax [x,ty] Nothing -> panic "The dictionary for `IP` is not a newtype?" - -\end{code} - +{- Note [Implicit parameter untouchables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We add the type variables in the types of the implicit parameters @@ -296,9 +293,8 @@ and will give a 'wrongThingErr' as a result. But the lookup of A won't fail. The _|_ (= panic "fakePatSynCon") works because the wrongThingErr call, in tcTyVar, doesn't look inside the TcTyThing. +-} - -\begin{code} tcValBinds :: TopLevelFlag -> [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM thing @@ -771,8 +767,8 @@ completeTheta inferred_theta <+> pprTheta inferred_diff , if suppress_hint then empty else pts_hint , typeSigCtxt (idName poly_id) sig ] -\end{code} +{- Note [Validity of inferred types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to check inferred type for validity, in case it uses language @@ -829,9 +825,8 @@ Notice that the impedence matcher may do defaulting. See Trac #7173. It also cleverly does an ambiguity check; for example, rejecting f :: F a -> a where F is a non-injective type function. +-} - -\begin{code} type PragFun = Name -> [LSig Name] mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun @@ -1069,8 +1064,8 @@ recoveryCode binder_names sig_fn forall_a_a :: TcType forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar) -\end{code} +{- Note [SPECIALISE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~ There is no point in a SPECIALISE pragma for a non-overloaded function: @@ -1092,11 +1087,11 @@ When (!:) is specialised it becomes non-recursive, and can usefully be inlined. Scary! So we only warn for SPECIALISE *without* INLINE for a non-overloaded function. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{tcMonoBind} -%* * -%************************************************************************ +* * +************************************************************************ @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. The signatures have been dealt with already. @@ -1122,8 +1117,8 @@ Note that should not typecheck because case id of { (f :: forall a. a->a) -> f } will not typecheck. +-} -\begin{code} tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes -- i.e. the binders are mentioned in their RHSs, and -- we are not rescued by a type signature @@ -1272,15 +1267,13 @@ getMonoBindInfo tc_binds where get_info (TcFunBind info _ _ _) rest = info : rest get_info (TcPatBind infos _ _ _) rest = infos ++ rest -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * Signatures -%* * -%************************************************************************ +* * +************************************************************************ Type signatures are tricky. See Note [Signature skolems] in TcType @@ -1358,8 +1351,8 @@ If a type signaure is wrong, fail immediately: ToDo: this means we fall over if any type sig is wrong (eg at the top level of the module), which is over-conservative +-} -\begin{code} tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun, [TcTyVar]) tcTySigs hs_sigs = checkNoErrs $ -- See Note [Fail eagerly on bad signatures] @@ -1603,19 +1596,18 @@ strictBindErr flavour unlifted_bndrs binds where msg | unlifted_bndrs = ptext (sLit "bindings for unlifted types") | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings") -\end{code} +{- Note [Binding scoped type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -%************************************************************************ -%* * +************************************************************************ +* * \subsection[TcBinds-errors]{Error contexts and messages} -%* * -%************************************************************************ +* * +************************************************************************ +-} - -\begin{code} -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc @@ -1631,5 +1623,3 @@ typeSigCtxt name (TcSigInfo { sig_id = _id, sig_tvs = tvs = sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name) <> colon , nest 2 (pprSigmaTypeExtraCts (isJust extra_cts) (mkSigmaTy (map snd tvs) theta tau)) ] - -\end{code} diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.hs index f6d9d2094c..dc782c124b 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.hs @@ -1,4 +1,3 @@ -\begin{code} {-# LANGUAGE CPP #-} module TcCanonical( canonicalize ) where @@ -25,14 +24,13 @@ import VarSet import Util import BasicTypes -\end{code} - -%************************************************************************ -%* * -%* The Canonicaliser * -%* * -%************************************************************************ +{- +************************************************************************ +* * +* The Canonicaliser * +* * +************************************************************************ Note [Canonicalization] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -117,10 +115,7 @@ not rewritten by subst, they remain canonical and hence we will not attempt to solve them from the EvBinds. If on the other hand they did get rewritten and are now non-canonical they will still not match the EvBinds, so we are again good. - - - -\begin{code} +-} -- Top-level canonicalization -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -162,16 +157,15 @@ canEvNC ev EqPred ty1 ty2 -> traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2) >> canEqNC ev ty1 ty2 TuplePred tys -> traceTcS "canEvNC:tup" (ppr tys) >> canTuple ev tys IrredPred {} -> traceTcS "canEvNC:irred" (ppr (ctEvPred ev)) >> canIrred ev -\end{code} - -%************************************************************************ -%* * -%* Tuple Canonicalization -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Tuple Canonicalization +* * +************************************************************************ +-} -\begin{code} canTuple :: CtEvidence -> [PredType] -> TcS (StopOrContinue Ct) canTuple ev tys = do { traceTcS "can_pred" (text "TuplePred!") @@ -179,15 +173,15 @@ canTuple ev tys xdecomp x = zipWith (\_ i -> EvTupleSel x i) tys [0..] ; xCtEvidence ev (XEvTerm tys xcomp xdecomp) ; stopWith ev "Decomposed tuple constraint" } -\end{code} -%************************************************************************ -%* * -%* Class Canonicalization -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Class Canonicalization +* * +************************************************************************ +-} -\begin{code} canClass, canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct) @@ -224,8 +218,8 @@ emitSuperclasses ct@(CDictCan { cc_ev = ev , cc_tyargs = xis_new, cc_class = cls -- superclasses to be executed if deferred to runtime! ; continueWith ct } emitSuperclasses _ = panic "emit_superclasses of non-class!" -\end{code} +{- Note [Adding superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Since dictionaries are canonicalized only once in their lifetime, the @@ -288,8 +282,8 @@ If we were to be adding the superclasses during simplification we'd get: While looks exactly like our original constraint. If we add the superclass again we'd loop. By adding superclasses definitely only once, during canonicalisation, this situation can't happen. +-} -\begin{code} newSCWorkFromFlavored :: CtEvidence -> Class -> [Xi] -> TcS () -- Returns superclasses, see Note [Adding superclasses] newSCWorkFromFlavored flavor cls xis @@ -325,17 +319,15 @@ is_improvement_pty ty = go (classifyPredType ty) where (_,fundeps) = classTvsFds cls go (TuplePred ts) = any is_improvement_pty ts go (IrredPred {}) = True -- Might have equalities after reduction? -\end{code} - -%************************************************************************ -%* * -%* Irreducibles canonicalization -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Irreducibles canonicalization +* * +************************************************************************ +-} - -\begin{code} canIrred :: CtEvidence -> TcS (StopOrContinue Ct) -- Precondition: ty not a tuple and no other evidence form canIrred old_ev @@ -369,26 +361,26 @@ canHole ev occ hole_sort , cc_hole = hole_sort }) ; stopWith new_ev "Emit insoluble hole" } Stop ev s -> return (Stop ev s) } -- Found a cached copy; won't happen -\end{code} -%************************************************************************ -%* * -%* Equalities -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Equalities +* * +************************************************************************ +-} -\begin{code} canEqNC :: CtEvidence -> Type -> Type -> TcS (StopOrContinue Ct) canEqNC ev ty1 ty2 = can_eq_nc ev ty1 ty1 ty2 ty2 -can_eq_nc, can_eq_nc' - :: CtEvidence - -> Type -> Type -- LHS, after and before type-synonym expansion, resp - -> Type -> Type -- RHS, after and before type-synonym expansion, resp +can_eq_nc, can_eq_nc' + :: CtEvidence + -> Type -> Type -- LHS, after and before type-synonym expansion, resp + -> Type -> Type -- RHS, after and before type-synonym expansion, resp -> TcS (StopOrContinue Ct) can_eq_nc ev ty1 ps_ty1 ty2 ps_ty2 - = do { traceTcS "can_eq_nc" $ + = do { traceTcS "can_eq_nc" $ vcat [ ppr ev, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ] ; can_eq_nc' ev ty1 ps_ty1 ty2 ps_ty2 } @@ -422,16 +414,16 @@ can_eq_nc' ev ty1@(LitTy l1) _ (LitTy l2) _ setEvBind (ctev_evar ev) (EvCoercion (mkTcNomReflCo ty1)) ; stopWith ev "Equal LitTy" } --- Decomposable type constructor applications +-- Decomposable type constructor applications -- Synonyms and type functions (which are not decomposable) --- have already been dealt with +-- have already been dealt with can_eq_nc' ev (TyConApp tc1 tys1) _ (TyConApp tc2 tys2) _ | isDecomposableTyCon tc1 , isDecomposableTyCon tc2 = canDecomposableTyConApp ev tc1 tys1 tc2 tys2 can_eq_nc' ev (TyConApp tc1 _) ps_ty1 (FunTy {}) ps_ty2 - | isDecomposableTyCon tc1 + | isDecomposableTyCon tc1 -- The guard is important -- e.g. (x -> y) ~ (F x y) where F has arity 1 -- should not fail, but get the app/app case @@ -441,7 +433,7 @@ can_eq_nc' ev (FunTy s1 t1) _ (FunTy s2 t2) _ = canDecomposableTyConAppOK ev funTyCon [s1,t1] [s2,t2] can_eq_nc' ev (FunTy {}) ps_ty1 (TyConApp tc2 _) ps_ty2 - | isDecomposableTyCon tc2 + | isDecomposableTyCon tc2 = canEqFailure ev ps_ty1 ps_ty2 can_eq_nc' ev s1@(ForAllTy {}) _ s2@(ForAllTy {}) _ @@ -503,12 +495,12 @@ can_eq_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2 else do { (xi_t1, co_t1) <- flatten fmode t1 -- We flatten t1 as well so that (xi_s1 xi_t1) is well-kinded - -- If we form (xi_s1 t1) that might (appear) ill-kinded, + -- If we form (xi_s1 t1) that might (appear) ill-kinded, -- and then crash in a call to typeKind ; let xi1 = mkAppTy xi_s1 xi_t1 co1 = mkTcAppCo co_s1 co_t1 ; traceTcS "can_eq_app 3" $ vcat [ ppr ev, ppr xi1, ppr co1 ] - ; mb_ct <- rewriteEqEvidence ev swapped xi1 ps_ty2 + ; mb_ct <- rewriteEqEvidence ev swapped xi1 ps_ty2 co1 (mkTcNomReflCo ps_ty2) ; traceTcS "can_eq_app 4" $ vcat [ ppr ev, ppr xi1, ppr co1 ] ; case mb_ct of @@ -526,7 +518,7 @@ can_eq_flat_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2 | otherwise = unSwap swapped (canEqFailure ev) ps_ty1 ps_ty2 where - decompose_it (s1,t1) (s2,t2) + decompose_it (s1,t1) (s2,t2) = do { let xevcomp [x,y] = EvCoercion (mkTcAppCo (evTermCoercion x) (evTermCoercion y)) xevcomp _ = error "canEqAppTy: can't happen" -- Can't happen xevdecomp x = let xco = evTermCoercion x @@ -571,18 +563,18 @@ canEqFailure ev ty1 ty2 ContinueWith new_ev -> do { emitInsoluble (mkNonCanonical new_ev) ; stopWith new_ev "Definitely not equal" } Stop ev s -> pprPanic "canEqFailure" (s $$ ppr ev $$ ppr ty1 $$ ppr ty2) } -\end{code} +{- Note [Canonicalising type applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given (s1 t1) ~ ty2, how should we proceed? -The simple things is to see if ty2 is of form (s2 t2), and +The simple things is to see if ty2 is of form (s2 t2), and decompose. By this time s1 and s2 can't be saturated type -function applications, because those have been dealt with -by an earlier equation in can_eq_nc, so it is always sound to +function applications, because those have been dealt with +by an earlier equation in can_eq_nc, so it is always sound to decompose. -However, over-eager decomposition gives bad error messages +However, over-eager decomposition gives bad error messages for things like a b ~ Maybe c e f ~ p -> q @@ -590,14 +582,14 @@ Suppose (in the first example) we already know a~Array. Then if we decompose the application eagerly, yielding a ~ Maybe b ~ c -we get an error "Can't match Array ~ Maybe", +we get an error "Can't match Array ~ Maybe", but we'd prefer to get "Can't match Array b ~ Maybe c". So instead can_eq_app flattens s1. If flattening does something, it -rewrites, and goes round can_eq_nc again. If flattening +rewrites, and goes round can_eq_nc again. If flattening does nothing, then (at least with our present state of knowledge) we can only decompose, and that is what can_eq_flat_app attempts -to do. +to do. Note [Make sure that insolubles are fully rewritten] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -630,15 +622,14 @@ As this point we have an insoluble constraint, like Int~Bool. case we don't want to get two (or more) error messages by generating two (or more) insoluble fundep constraints from the same class constraint. +-} - -\begin{code} -canCFunEqCan :: CtEvidence +canCFunEqCan :: CtEvidence -> TyCon -> [TcType] -- LHS -> TcTyVar -- RHS -> TcS (StopOrContinue Ct) --- ^ Canonicalise a CFunEqCan. We know that --- the arg types are already flat, +-- ^ Canonicalise a CFunEqCan. We know that +-- the arg types are already flat, -- and the RHS is a fsk, which we must *not* substitute. -- So just substitute in the LHS canCFunEqCan ev fn tys fsk @@ -695,7 +686,7 @@ canEqTyVar2 :: DynFlags -> TcType -- nrhs -> TcCoercion -- nrhs ~ orhs -> TcS (StopOrContinue Ct) --- LHS is an inert type variable, +-- LHS is an inert type variable, -- and RHS is fully rewritten, but with type synonyms -- preserved as much as possible @@ -713,7 +704,7 @@ canEqTyVar2 dflags ev swapped tv1 xi2 co2 k2 = typeKind xi2' ; case mb of Stop ev s -> return (Stop ev s) - ContinueWith new_ev + ContinueWith new_ev | k2 `isSubKind` k1 -- Establish CTyEqCan kind invariant -- Reorientation has done its best, but the kinds might @@ -854,8 +845,8 @@ incompatibleKind new_ev s1 k1 s2 k2 -- See Note [Equalities with incompatible where loc = ctEvLoc new_ev kind_co_loc = setCtLocOrigin loc (KindEqOrigin s1 s2 (ctLocOrigin loc)) -\end{code} +{- Note [Canonical orientation for tyvar/tyvar equality constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we have a ~ b where both 'a' and 'b' are TcTyVars, which way @@ -1033,4 +1024,4 @@ not contain the variable from the LHS. In particular, given we first try expanding each of the ti to types which no longer contain a. If this turns out to be impossible, we next try expanding F itself, and so on. See Note [Occurs check expansion] in TcType - +-} diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.hs index 769167ff4b..719c2f3eb5 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Typechecking class declarations +-} -\begin{code} {-# LANGUAGE CPP #-} module TcClassDcl ( tcClassSigs, tcClassDecl2, @@ -45,9 +45,8 @@ import BooleanFormula import Util import Control.Monad -\end{code} - +{- Dictionary handling ~~~~~~~~~~~~~~~~~~~ Every class implicitly declares a new data type, corresponding to dictionaries @@ -81,13 +80,13 @@ Now DictTy in Type is just a form of type synomym: Death to "ExpandingDicts". -%************************************************************************ -%* * +************************************************************************ +* * Type-checking the class op signatures -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcClassSigs :: Name -- Name of the class -> [LSig Name] -> LHsBinds Name @@ -131,16 +130,15 @@ tcClassSigs clas sigs def_methods tc_gen_sig (op_names, gen_hs_ty) = do { gen_op_ty <- tcClassSigType gen_hs_ty ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Class Declarations -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcClassDecl2 :: LTyClDecl Name -- The class declaration -> TcM (LHsBinds Id) @@ -282,9 +280,7 @@ tcClassMinimalDef _clas sigs op_info defMindef = mkAnd [ mkVar name | (name, NoDM, _) <- op_info , not (startsWithUnderscore (getOccName name)) ] -\end{code} -\begin{code} instantiateMethod :: Class -> Id -> [TcType] -> TcType -- Take a class operation, say -- op :: forall ab. C a => forall c. Ix c => (b,c) -> a @@ -343,8 +339,8 @@ findMinimalDef = firstJusts . map toMinimalDef toMinimalDef :: LSig Name -> Maybe ClassMinimalDef toMinimalDef (L _ (MinimalSig bf)) = Just (fmap unLoc bf) toMinimalDef _ = Nothing -\end{code} +{- Note [Polymorphic methods] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -372,13 +368,13 @@ and wrap it in a let, thus This makes the error messages right. -%************************************************************************ -%* * +************************************************************************ +* * Error messages -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcMkDeclCtxt :: TyClDecl Name -> SDoc tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl, ptext (sLit "declaration for"), quotes (ppr (tcdName decl))] @@ -427,4 +423,3 @@ warningMinimalDefIncomplete mindef = vcat [ ptext (sLit "The MINIMAL pragma does not require:") , nest 2 (pprBooleanFormulaNice mindef) , ptext (sLit "but there is no default implementation.") ] -\end{code} diff --git a/compiler/typecheck/TcDefaults.lhs b/compiler/typecheck/TcDefaults.hs index 0153e5a9a4..c9ce0f6366 100644 --- a/compiler/typecheck/TcDefaults.lhs +++ b/compiler/typecheck/TcDefaults.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1993-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + \section[TcDefaults]{Typechecking \tr{default} declarations} +-} -\begin{code} module TcDefaults ( tcDefaults ) where import HsSyn @@ -21,9 +21,7 @@ import SrcLoc import Data.Maybe import Outputable import FastString -\end{code} -\begin{code} tcDefaults :: [LDefaultDecl Name] -> TcM (Maybe [Type]) -- Defaulting types to heave -- into Tc monad for later use @@ -98,5 +96,3 @@ badDefaultTy :: Type -> [Class] -> SDoc badDefaultTy ty deflt_clss = hang (ptext (sLit "The default type") <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) 2 (foldr1 (\a b -> a <+> ptext (sLit "or") <+> b) (map (quotes. ppr) deflt_clss)) -\end{code} - diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.hs index 76b8423130..d52a7216da 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Handles @deriving@ clauses on @data@ declarations. +-} -\begin{code} {-# LANGUAGE CPP #-} module TcDeriv ( tcDeriving ) where @@ -64,13 +64,13 @@ import Pair import Control.Monad import Data.List -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Overview -%* * -%************************************************************************ +* * +************************************************************************ Overall plan ~~~~~~~~~~~~ @@ -80,9 +80,8 @@ Overall plan 2. Infer the missing contexts for the InferTheta's 3. Add the derived bindings, generating InstInfos +-} - -\begin{code} -- DerivSpec is purely local to this module data DerivSpec theta = DS { ds_loc :: SrcSpan , ds_name :: Name -- DFun name @@ -108,8 +107,8 @@ data DerivSpec theta = DS { ds_loc :: SrcSpan -- ds_newtype = True <=> Generalised Newtype Deriving (GND) -- False <=> Vanilla deriving -\end{code} +{- Example: newtype instance T [a] = MkT (Tree a) deriving( C s ) @@ -120,8 +119,8 @@ Example: DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]] , ds_tc = :RTList, ds_tc_args = [a] , ds_newtype = True } +-} -\begin{code} type DerivContext = Maybe ThetaType -- Nothing <=> Vanilla deriving; infer the context of the instance decl -- Just theta <=> Standalone deriving: context supplied by programmer @@ -185,9 +184,8 @@ instance Outputable EarlyDerivSpec where instance Outputable PredOrigin where ppr (PredOrigin ty _) = ppr ty -- The origin is not so interesting when debugging -\end{code} - +{- Inferring missing contexts ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -342,13 +340,13 @@ See Trac #3221. Consider Are T1 and T2 unused? Well, no: the deriving clause expands to mention both of them. So we gather defs/uses from deriving just like anything else. -%************************************************************************ -%* * +************************************************************************ +* * \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcDeriving :: [LTyClDecl Name] -- All type constructors -> [LInstDecl Name] -- All instance declarations -> [LDerivDecl Name] -- All stand-alone deriving declarations @@ -490,8 +488,8 @@ renameDeriv is_boot inst_infos bagBinds , ib_extensions = exts , ib_derived = sa } ; return (inst_info { iBinds = binds' }, fvs) } -\end{code} +{- Note [Newtype deriving and unused constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (see Trac #1954): @@ -511,15 +509,15 @@ So we want to signal a user of the data constructor 'MkP'. This is the reason behind the (Maybe Name) part of the return type of genInst. -%************************************************************************ -%* * +************************************************************************ +* * From HsSyn to DerivSpec -%* * -%************************************************************************ +* * +************************************************************************ @makeDerivSpecs@ fishes around to find the info about needed derived instances. +-} -\begin{code} makeDerivSpecs :: Bool -> [LTyClDecl Name] -> [LInstDecl Name] @@ -606,8 +604,8 @@ deriveFamInst decl@(DataFamInstDecl concatMapM (deriveTyData True tvs' fam_tc pats') preds } deriveFamInst _ = return [] -\end{code} +{- Note [Finding the LHS patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When kind polymorphism is in play, we need to be careful. Here is @@ -626,9 +624,8 @@ So CmpInterval is kind-polymorphic, but the data instance is not Hence, when deriving the type patterns in deriveFamInst, we must kind check the RHS (the data constructor 'Starting c') as well as the LHS, so that we correctly see the instantiation to *. +-} - -\begin{code} ------------------------------------------------------------------ deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec] -- Standalone deriving declarations @@ -809,8 +806,8 @@ derivePolyKindedTypeable is_instance cls cls_tys _tvs tc tc_args (classArgsErr cls cls_tys) ; mkPolyKindedTypeableEqn cls tc } -\end{code} +{- Note [Unify kinds in deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (Trac #8534) @@ -865,9 +862,8 @@ When deriving Functor for P, we unify k to *, but we then want an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*)) and similarly for C. Notice the modified kind of x, both at binding and occurrence sites. +-} - -\begin{code} mkEqnHelp :: Maybe OverlapMode -> [TyVar] -> Class -> [Type] @@ -921,8 +917,8 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta tycon tc_args rep_tc rep_tc_args mtheta } where bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) -\end{code} +{- Note [Looking up family instances for deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tcLookupFamInstExact is an auxiliary lookup wrapper which requires @@ -982,13 +978,13 @@ write it out See Note [Eta reduction for data family axioms] in TcInstDcls. -%************************************************************************ -%* * +************************************************************************ +* * Deriving data types -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkDataTypeEqn :: DynFlags -> Maybe OverlapMode -> [Var] -- Universally quantified type variables in the instance @@ -1159,8 +1155,8 @@ inferConstraints cls inst_tys rep_tc rep_tc_args = [mkPredOrigin DerivOrigin (mkClassPred cls [ty]) | ty <- rep_tc_args] | otherwise = [] -\end{code} +{- Note [Getting base classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Functor and Typeable are defined in package 'base', and that is not available @@ -1210,8 +1206,8 @@ GHC uses the same heuristic for figuring out the class context that it uses for Eq in the case of *-kinded classes, and for Functor in the case of * -> *-kinded classes. That may not be optimal or even wrong. But in such cases, standalone deriving can still be used. +-} -\begin{code} ------------------------------------------------------------------ -- Check side conditions that dis-allow derivability for particular classes -- This is *apart* from the newtype-deriving mechanism @@ -1478,8 +1474,8 @@ new_dfun_name clas tycon -- Just a simple wrapper badCon :: DataCon -> SDoc -> SDoc badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg -\end{code} +{- Note [Check that the type variable is truly universal] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For Functor, Foldable, Traversable, we must check that the *last argument* @@ -1527,13 +1523,13 @@ a context for the Data instances: instance Typable a => Data (T a) where ... -%************************************************************************ -%* * +************************************************************************ +* * Deriving newtypes -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [Var] -> Class -> [Type] -> TyCon -> [Type] -> TyCon -> [Type] -> DerivContext @@ -1706,8 +1702,8 @@ mkNewTypeEqn dflags overlap_mode tvs , ppUnless ats_ok ats_msg ] eta_msg = ptext (sLit "cannot eta-reduce the representation type enough") ats_msg = ptext (sLit "the class has associated types") -\end{code} +{- Note [Recursive newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~ Newtype deriving works fine, even if the newtype is recursive. @@ -1738,11 +1734,11 @@ is because the derived instance uses `coerce`, which must satisfy its `Coercible` constraint. This is different than other deriving scenarios, where we're sure that the resulting instance will type-check. -%************************************************************************ -%* * +************************************************************************ +* * \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations} -%* * -%************************************************************************ +* * +************************************************************************ A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv) terms, which is the final correct RHS for the corresponding original @@ -1757,8 +1753,8 @@ The (k,TyVarTy tv) pairs in a solution are canonically ordered by sorting on type varible, tv, (major key) and then class, k, (minor key) \end{itemize} +-} -\begin{code} inferInstanceContexts :: [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType] inferInstanceContexts [] = return [] @@ -1835,16 +1831,15 @@ extendLocalInstEnv dfuns thing_inside ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns env' = env { tcg_inst_env = inst_env' } ; setGblEnv env' thing_inside } -\end{code} - +{- *********************************************************************************** * * * Simplify derived constraints * * *********************************************************************************** +-} -\begin{code} simplifyDeriv :: PredType -> [TyVar] -> ThetaOrigin -- Wanted @@ -1890,8 +1885,8 @@ simplifyDeriv pred tvs theta ; let min_theta = mkMinimalBySCs (bagToList good) ; return (substTheta subst_skol min_theta) } -\end{code} +{- Note [Overlap and deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider some overlapping instances: @@ -1969,11 +1964,11 @@ The bottom line Allow constraints which consist only of type variables, with no repeats. -%************************************************************************ -%* * +************************************************************************ +* * \subsection[TcDeriv-normal-binds]{Bindings for the various classes} -%* * -%************************************************************************ +* * +************************************************************************ After all the trouble to figure out the required context for the derived instance declarations, all that's left is to chug along to @@ -2030,8 +2025,8 @@ possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. So, instead, we produce @MonoBinds RdrName@ then heave 'em through the renamer. What a great hack! \end{itemize} +-} -\begin{code} -- Generate the InstInfo for the required instance paired with the -- *representation* tycon for that instance, -- plus any auxiliary bindings required @@ -2113,8 +2108,8 @@ getDataConFixityFun tc where name = tyConName tc doc = ptext (sLit "Data con fixities for") <+> ppr name -\end{code} +{- Note [Bindings for Generalised Newtype Deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -2136,13 +2131,13 @@ representation type. See the paper "Safe zero-cost coercions for Hsakell". -%************************************************************************ -%* * +************************************************************************ +* * \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} derivingNullaryErr :: MsgDoc derivingNullaryErr = ptext (sLit "Cannot derive instances for nullary classes") @@ -2182,4 +2177,3 @@ standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for" derivInstCtxt :: PredType -> MsgDoc derivInstCtxt pred = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) -\end{code} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.hs index c4a3f2f0d3..9414dcb5fb 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.hs @@ -1,8 +1,5 @@ -% -% (c) The University of Glasgow 2006 -% +-- (c) The University of Glasgow 2006 -\begin{code} {-# LANGUAGE CPP, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -11,28 +8,28 @@ module TcEnv( -- Instance environment, and InstInfo type InstInfo(..), iDFunId, pprInstInfoDetails, - simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, + simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, InstBindings(..), -- Global environment tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv, tcExtendGlobalValEnv, - tcLookupLocatedGlobal, tcLookupGlobal, + tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupAxiom, - + -- Local environment tcExtendKindEnv, tcExtendKindEnv2, - tcExtendTyVarEnv, tcExtendTyVarEnv2, + tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendLetEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcExtendIdEnv3, tcExtendIdBndrs, tcExtendGhciIdEnv, - tcLookup, tcLookupLocated, tcLookupLocalIds, - tcLookupId, tcLookupTyVar, - tcLookupLcl_maybe, + tcLookup, tcLookupLocated, tcLookupLocalIds, + tcLookupId, tcLookupTyVar, + tcLookupLcl_maybe, getScopedTyVarBinds, getInLocalScope, wrongThingErr, pprBinders, @@ -51,7 +48,7 @@ module TcEnv( tcGetGlobalTyVars, zapLclTypeEnv, -- Template Haskell stuff - checkWellStaged, tcMetaTy, thLevel, + checkWellStaged, tcMetaTy, thLevel, topIdLvl, isBrackStage, -- New Ids @@ -67,7 +64,7 @@ import IfaceEnv import TcRnMonad import TcMType import TcType -import TcIface +import TcIface import PrelNames import TysWiredIn import Id @@ -99,20 +96,19 @@ import Util import Maybes( MaybeErr(..) ) import Data.IORef import Data.List -\end{code} - -%************************************************************************ -%* * -%* tcLookupGlobal * -%* * -%************************************************************************ +{- +************************************************************************ +* * +* tcLookupGlobal * +* * +************************************************************************ Using the Located versions (eg. tcLookupLocatedGlobal) is preferred, unless you know that the SrcSpan in the monad is already set to the span of the Name. +-} -\begin{code} tcLookupLocatedGlobal :: Located Name -> TcM TyThing -- c.f. IfaceEnvEnv.tcIfaceGlobal tcLookupLocatedGlobal name @@ -215,14 +211,14 @@ tcLookupInstance :: Class -> [Type] -> TcM ClsInst tcLookupInstance cls tys = do { instEnv <- tcGetInstEnvs ; case lookupUniqueInstEnv instEnv cls tys of - Left err -> failWithTc $ ptext (sLit "Couldn't match instance:") <+> err - Right (inst, tys) + Left err -> failWithTc $ ptext (sLit "Couldn't match instance:") <+> err + Right (inst, tys) | uniqueTyVars tys -> return inst | otherwise -> failWithTc errNotExact } where errNotExact = ptext (sLit "Not an exact match (i.e., some variables get instantiated)") - + uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map extractTyVar tys) where extractTyVar (TyVarTy tv) = tv @@ -236,23 +232,20 @@ tcGetInstEnvs = do { eps <- getEps ; return (InstEnvs { ie_global = eps_inst_env eps , ie_local = tcg_inst_env env , ie_visible = tcg_visible_orphan_mods env }) } -\end{code} -\begin{code} instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where lookupThing = tcLookupGlobal -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Extending the global environment -%* * -%************************************************************************ - +* * +************************************************************************ +-} -\begin{code} setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv --- Use this to update the global type env +-- Use this to update the global type env -- It updates both * the normal tcg_type_env field -- * the tcg_type_env_var field seen by interface files setGlobalTypeEnv tcg_env new_type_env @@ -285,7 +278,7 @@ tcExtendGlobalEnv things thing_inside tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a -- Same deal as tcExtendGlobalEnv, but for Ids -tcExtendGlobalValEnv ids thing_inside +tcExtendGlobalValEnv ids thing_inside = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r @@ -293,19 +286,18 @@ tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r -- Just like tcExtendGlobalEnv, except the argument is a list of pairs tcExtendRecEnv gbl_stuff thing_inside = do { tcg_env <- getGblEnv - ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff + ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff ; tcg_env' <- setGlobalTypeEnv tcg_env ge' ; setGblEnv tcg_env' thing_inside } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{The local environment} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcLookupLocated :: Located Name -> TcM TcTyThing tcLookupLocated = addLocM tcLookup @@ -329,9 +321,9 @@ tcLookupTyVar name _ -> pprPanic "tcLookupTyVar" (ppr name) } tcLookupId :: Name -> TcM Id --- Used when we aren't interested in the binding level, nor refinement. +-- Used when we aren't interested in the binding level, nor refinement. -- The "no refinement" part means that we return the un-refined Id regardless --- +-- -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId) tcLookupId name = do thing <- tcLookup name @@ -343,11 +335,11 @@ tcLookupId name = do tcLookupLocalIds :: [Name] -> TcM [TcId] -- We expect the variables to all be bound, and all at -- the same level as the lookup. Only used in one place... -tcLookupLocalIds ns +tcLookupLocalIds ns = do { env <- getLclEnv ; return (map (lookup (tcl_env env)) ns) } where - lookup lenv name + lookup lenv name = case lookupNameEnv lenv name of Just (ATcId { tct_id = id }) -> id _ -> pprPanic "tcLookupLocalIds" (ppr name) @@ -356,9 +348,7 @@ getInLocalScope :: TcM (Name -> Bool) -- Ids only getInLocalScope = do { lcl_env <- getLclTypeEnv ; return (`elemNameEnv` lcl_env) } -\end{code} -\begin{code} tcExtendKindEnv2 :: [(Name, TcTyThing)] -> TcM r -> TcM r -- Used only during kind checking, for TcThings that are -- AThing or APromotionErr @@ -404,8 +394,8 @@ getScopedTyVarBinds :: TcM [(Name, TcTyVar)] getScopedTyVarBinds = do { lcl_env <- getLclEnv ; return [(name, tv) | ATyVar name tv <- nameEnvElts (tcl_env lcl_env)] } -\end{code} +{- Note [Initialising the type environment for GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tcExtendGhciIdEnv extends the local type environemnt with GHCi @@ -443,8 +433,8 @@ Note especially that well. We are just shadowing them here to deal with the global tyvar stuff. That's why we can simply drop the External-Name ones; they will be found in the global envt +-} -\begin{code} tcExtendGhciIdEnv :: [TyThing] -> TcM a -> TcM a -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction -- See Note [Initialising the type environment for GHCi] @@ -471,13 +461,13 @@ tcExtendLetEnv top_lvl closed ids thing_inside tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] thing_inside } tcExtendIdEnv :: [TcId] -> TcM a -> TcM a -tcExtendIdEnv ids thing_inside +tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] $ - tcExtendIdBndrs [TcIdBndr id NotTopLevel | id <- ids] + tcExtendIdBndrs [TcIdBndr id NotTopLevel | id <- ids] thing_inside tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a -tcExtendIdEnv1 name id thing_inside +tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] $ tcExtendIdBndrs [TcIdBndr id NotTopLevel] thing_inside @@ -587,16 +577,15 @@ zapLclTypeEnv thing_inside , tcl_rdr = emptyLocalRdrEnv , tcl_tyvars = tvs_var } ; updLclEnv upd thing_inside } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Rules} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a -- Just pop the new rules into the EPS and envt resp -- All the rules come from an interface file, not source @@ -607,16 +596,15 @@ tcExtendRules lcl_rules thing_inside ; let env' = env { tcg_rules = lcl_rules ++ tcg_rules env } ; setGblEnv env' thing_inside } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Meta level -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} checkWellStaged :: SDoc -- What the stage check is for -> ThLevel -- Binding level (increases inside brackets) -> ThLevel -- Use stage @@ -630,32 +618,32 @@ checkWellStaged pp_thing bind_lvl use_lvl | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) - ptext (sLit "Stage error:") <+> pp_thing <+> + ptext (sLit "Stage error:") <+> pp_thing <+> hsep [ptext (sLit "is bound at stage") <+> ppr bind_lvl, ptext (sLit "but used at stage") <+> ppr use_lvl] stageRestrictionError :: SDoc -> TcM a stageRestrictionError pp_thing - = failWithTc $ + = failWithTc $ sep [ ptext (sLit "GHC stage restriction:") , nest 2 (vcat [ pp_thing <+> ptext (sLit "is used in a top-level splice or annotation,") , ptext (sLit "and must be imported, not defined locally")])] topIdLvl :: Id -> ThLevel --- Globals may either be imported, or may be from an earlier "chunk" +-- Globals may either be imported, or may be from an earlier "chunk" -- (separated by declaration splices) of this module. The former -- *can* be used inside a top-level splice, but the latter cannot. -- Hence we give the former impLevel, but the latter topLevel -- E.g. this is bad: -- x = [| foo |] -- $( f x ) --- By the time we are prcessing the $(f x), the binding for "x" +-- By the time we are prcessing the $(f x), the binding for "x" -- will be in the global env, not the local one. topIdLvl id | isLocalId id = outerLevel | otherwise = impLevel tcMetaTy :: Name -> TcM Type --- Given the name of a Template Haskell data type, +-- Given the name of a Template Haskell data type, -- return the type -- E.g. given the name "Expr" return the type "Expr" tcMetaTy tc_name = do @@ -665,16 +653,15 @@ tcMetaTy tc_name = do isBrackStage :: ThStage -> Bool isBrackStage (Brack {}) = True isBrackStage _other = False -\end{code} - -%************************************************************************ -%* * - getDefaultTys -%* * -%************************************************************************ +{- +************************************************************************ +* * + getDefaultTys +* * +************************************************************************ +-} -\begin{code} tcGetDefaultTys :: TcM ([Type], -- Default types (Bool, -- True <=> Use overloaded strings Bool)) -- True <=> Use extended defaulting rules @@ -682,9 +669,9 @@ tcGetDefaultTys = do { dflags <- getDynFlags ; let ovl_strings = xopt Opt_OverloadedStrings dflags extended_defaults = xopt Opt_ExtendedDefaultRules dflags - -- See also Trac #1974 + -- See also Trac #1974 flags = (ovl_strings, extended_defaults) - + ; mb_defaults <- getDeclaredDefaultTys ; case mb_defaults of { Just tys -> return (tys, flags) ; @@ -703,13 +690,13 @@ tcGetDefaultTys where opt_deflt True ty = [ty] opt_deflt False _ = [] -\end{code} +{- Note [Default unitTy] ~~~~~~~~~~~~~~~~~~~~~ In interative mode (or with -XExtendedDefaultRules) we add () as the first type we try when defaulting. This has very little real impact, except in the following case. -Consider: +Consider: Text.Printf.printf "hello" This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to @@ -718,11 +705,11 @@ and then GHCi doesn't attempt to print the (). So in interactive mode, we add () to the list of defaulting types. See Trac #1200. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{The InstInfo type} -%* * -%************************************************************************ +* * +************************************************************************ The InstInfo type summarises the information in an instance declaration @@ -733,8 +720,8 @@ But local instance decls includes - derived ones - generic ones as well as explicit user written ones. +-} -\begin{code} data InstInfo a = InstInfo { iSpec :: ClsInst, -- Includes the dfun id. Its forall'd type @@ -787,27 +774,27 @@ simpleInstInfoTyCon :: InstInfo a -> TyCon -- Gets the type constructor for a simple instance declaration, -- i.e. one of the form instance (...) => C (T a b c) where ... simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) -\end{code} +{- Make a name for the dict fun for an instance decl. It's an *external* name, like otber top-level names, and hence must be made with newGlobalBinder. +-} -\begin{code} newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name newDFunName clas tys loc = do { is_boot <- tcIsHsBootOrSig ; mod <- getModule - ; let info_string = occNameString (getOccName clas) ++ + ; let info_string = occNameString (getOccName clas) ++ concatMap (occNameString.getDFunTyKey) tys ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) ; newGlobalBinder mod dfun_occ loc } -\end{code} +{- Make a name for the representation tycon of a family instance. It's an *external* name, like other top-level names, and hence must be made with newGlobalBinder. +-} -\begin{code} newFamInstTyConName :: Located Name -> [Type] -> TcM Name newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] @@ -818,22 +805,22 @@ newFamInstAxiomName loc name branches mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name mk_fam_inst_name adaptOcc loc tc_name tyss = do { mod <- getModule - ; let info_string = occNameString (getOccName tc_name) ++ + ; let info_string = occNameString (getOccName tc_name) ++ intercalate "|" ty_strings ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) ; newGlobalBinder mod (adaptOcc occ) loc } where ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss -\end{code} +{- Stable names used for foreign exports and annotations. For stable names, the name must be unique (see #1533). If the same thing has several stable Ids based on it, the top-level bindings generated must not have the same name. Hence we create an External name (doesn't change), and we append a Unique to the string right here. +-} -\begin{code} mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId mkStableIdFromString str sig_ty loc occ_wrapper = do uniq <- newUnique @@ -846,9 +833,7 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId mkStableIdFromName nm = mkStableIdFromString (getOccString nm) -\end{code} -\begin{code} mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m) => String -> String -> m FastString mkWrapperName what nameBase @@ -878,15 +863,15 @@ spurious ABI change (#4012). The wrapper counter has to be per-module, not global, so that the number we end up using is not dependent on the modules compiled before the current one. -} -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Errors} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} pprBinders :: [Name] -> SDoc -- Used in error messages -- Use quotes for a single one; they look a bit "busy" for several @@ -894,13 +879,13 @@ pprBinders [bndr] = quotes (ppr bndr) pprBinders bndrs = pprWithCommas ppr bndrs notFound :: Name -> TcM TyThing -notFound name +notFound name = do { lcl_env <- getLclEnv ; let stage = tcl_th_ctxt lcl_env ; case stage of -- See Note [Out of scope might be a staging error] Splice {} -> stageRestrictionError (quotes (ppr name)) _ -> failWithTc $ - vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> + vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> ptext (sLit "is not in scope during type checking, but it passed the renamer"), ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl_env)] -- Take case: printing the whole gbl env can @@ -911,14 +896,14 @@ notFound name } wrongThingErr :: String -> TcTyThing -> Name -> TcM a --- It's important that this only calls pprTcTyThingCategory, which in +-- It's important that this only calls pprTcTyThingCategory, which in -- turn does not look at the details of the TcTyThing. -- See Note [Placeholder PatSyn kinds] in TcBinds wrongThingErr expected thing name - = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> + = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> ptext (sLit "used as a") <+> text expected) -\end{code} +{- Note [Out of scope might be a staging error] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -930,3 +915,4 @@ But in fact the type checker processes types first, so 'x' won't even be in the type envt when we look for it in $(foo x). So inside splices we report something missing from the type env as a staging error. See Trac #5752 and #5795. +-} diff --git a/compiler/typecheck/TcEnv.hs-boot b/compiler/typecheck/TcEnv.hs-boot new file mode 100644 index 0000000000..4d291e27ca --- /dev/null +++ b/compiler/typecheck/TcEnv.hs-boot @@ -0,0 +1,6 @@ +{- +>module TcEnv where +>import TcRnTypes +> +>tcExtendIdEnv :: [TcId] -> TcM a -> TcM a +-} diff --git a/compiler/typecheck/TcEnv.lhs-boot b/compiler/typecheck/TcEnv.lhs-boot deleted file mode 100644 index 4f25cee59c..0000000000 --- a/compiler/typecheck/TcEnv.lhs-boot +++ /dev/null @@ -1,4 +0,0 @@ ->module TcEnv where ->import TcRnTypes -> ->tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
\ No newline at end of file diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.hs index c8406dfb39..6409d6d186 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.hs @@ -1,4 +1,3 @@ -\begin{code} {-# LANGUAGE CPP, ScopedTypeVariables #-} module TcErrors( @@ -46,13 +45,13 @@ import ListSetOps ( equivClasses ) import Control.Monad ( when ) import Data.Maybe import Data.List ( partition, mapAccumL, zip4, nub, sortBy ) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \section{Errors and contexts} -%* * -%************************************************************************ +* * +************************************************************************ ToDo: for these error messages, should we note the location as coming from the insts, or just whatever seems to be around in the monad just @@ -94,8 +93,8 @@ It does this by keeping track of which errors correspond to which coercion in TcErrors. TcErrors.reportTidyWanteds does not print the errors and does not fail if -fdefer-type-errors is on, so that we can continue compilation. The errors are turned into warnings in `reportUnsolved`. +-} -\begin{code} reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) reportUnsolved wanted = do { binds_var <- newTcEvBinds @@ -186,8 +185,8 @@ data ReportErrCtxt -- don't issue any more errors/warnings -- See Note [Suppressing error messages] } -\end{code} +{- Note [Suppressing error messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The cec_suppress flag says "don't report any errors. Instead, just create @@ -198,9 +197,8 @@ Specifically (see reportWanteds) * If there are any insolubles (eg Int~Bool), here or in a nested implication, then suppress errors from the flat constraints here. Sometimes the flat-constraint errors are a knock-on effect of the insolubles. +-} - -\begin{code} reportImplic :: ReportErrCtxt -> Implication -> TcM () reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given , ic_wanted = wanted, ic_binds = evb @@ -491,8 +489,8 @@ getUserGivens (CEC {cec_encl = ctxt}) | Implic { ic_given = givens, ic_env = env , ic_no_eqs = no_eqs, ic_info = info } <- ctxt , not (null givens) ] -\end{code} +{- Note [Always warn with -fdefer-type-errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When -fdefer-type-errors is on we warn about *all* type errors, even @@ -559,13 +557,13 @@ And now we have a problem as we will generate an equality b ~ b' and fail to solve it. -%************************************************************************ -%* * +************************************************************************ +* * Irreducible predicate errors -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkIrredErr ctxt cts = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct1 @@ -621,14 +619,13 @@ mkIPErr ctxt cts , nest 2 (pprTheta preds) ] | otherwise = couldNotDeduce givens (preds, orig) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Equality errors -%* * -%************************************************************************ +* * +************************************************************************ Note [Inaccessible code] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -647,8 +644,8 @@ Here the second equation is unreachable. The original constraint the *signature* (Trac #7293). So, for Given errors we replace the env (and hence src-loc) on its CtLoc with that from the immediately enclosing implication. +-} -\begin{code} mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do! @@ -671,7 +668,7 @@ mkEqErr1 ctxt ct ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig ; dflags <- getDynFlags - ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig) + ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig) ; mkEqErr_help dflags (ctxt {cec_tidy = env1}) (wanted_msg $$ binds_msg) ct is_oriented ty1 ty2 } @@ -988,8 +985,8 @@ sameOccExtra ty1 ty2 pkg = modulePackageKey mod mod = nameModule nm loc = nameSrcSpan nm -\end{code} +{- Note [Suggest adding a type signature] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The OutsideIn algorithm rejects GADT programs that don't have a principal @@ -1040,13 +1037,13 @@ so mkTyFunInfoMsg adds: Warn of loopy local equalities that were dropped. -%************************************************************************ -%* * +************************************************************************ +* * Type-class errors -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkDictErr ctxt cts = ASSERT( not (null cts) ) @@ -1134,7 +1131,7 @@ mk_dict_err fam_envs ctxt (ct, (matches, unifiers, safe_haskell)) add_to_ctxt_fixes has_ambig_tvs | not has_ambig_tvs && all_tyvars - , (orig:origs) <- usefulContext ctxt pred + , (orig:origs) <- usefulContext ctxt pred = [sep [ ptext (sLit "add") <+> pprParendType pred <+> ptext (sLit "to the context of") , nest 2 $ ppr_skol orig $$ @@ -1346,8 +1343,8 @@ quickFlattenTy (TyConApp tc tys) ; v <- newMetaTyVar (TauTv False) (typeKind (TyConApp tc funtys)) ; flat_resttys <- mapM quickFlattenTy resttys ; return (foldl AppTy (mkTyVarTy v) flat_resttys) } -\end{code} +{- Note [Flattening in error message generation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (C (Maybe (F x))), where F is a type function, and we have @@ -1380,8 +1377,8 @@ The reason may be that the kinds don't match up. Typically you'll get more useful information, but not when it's as a result of ambiguity. This test suggests -fprint-explicit-kinds when all the ambiguous type variables are kind variables. +-} -\begin{code} mkAmbigMsg :: Ct -> (Bool, SDoc) mkAmbigMsg ct | null ambig_tkvs = (False, empty) @@ -1498,7 +1495,7 @@ relevantBindings want_filtering ctxt ct <+> ppr (getSrcLoc id)))] new_seen = tvs_seen `unionVarSet` id_tvs - ; if (want_filtering && not opt_PprStyle_Debug + ; if (want_filtering && not opt_PprStyle_Debug && id_tvs `disjointVarSet` ct_tvs) -- We want to filter out this binding anyway -- so discard it silently @@ -1530,22 +1527,22 @@ warnDefaulting wanteds default_ty <+> quotes (ppr default_ty)) 2 ppr_wanteds ; setCtLoc loc $ warnTc warn_default warn_msg } -\end{code} +{- Note [Runtime skolems] ~~~~~~~~~~~~~~~~~~~~~~ We want to give a reasonably helpful error message for ambiguity arising from *runtime* skolems in the debugger. These are created by in RtClosureInspect.zonkRTTIType. -%************************************************************************ -%* * +************************************************************************ +* * Error from the canonicaliser These ones are called *during* constraint simplification -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} solverDepthErrorTcS :: SubGoalCounter -> CtEvidence -> TcM a solverDepthErrorTcS cnt ev = setCtLoc loc $ @@ -1564,5 +1561,3 @@ solverDepthErrorTcS cnt ev msg CountTyFunApps = vcat [ ptext (sLit "Type function application stack overflow; size =") <+> int value , ptext (sLit "Use -ftype-function-depth=N to increase stack size to N") ] -\end{code} - diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.hs index 83f6596e3d..5e4f4e8aa2 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.hs @@ -1,8 +1,5 @@ -% -% (c) The University of Glasgow 2006 -% +-- (c) The University of Glasgow 2006 -\begin{code} {-# LANGUAGE CPP, DeriveDataTypeable #-} module TcEvidence ( @@ -57,9 +54,8 @@ import qualified Data.Data as Data import Outputable import FastString import Data.IORef( IORef ) -\end{code} - +{- Note [TcCoercions] ~~~~~~~~~~~~~~~~~~ | TcCoercions are a hack used by the typechecker. Normally, @@ -95,8 +91,8 @@ differences * TcAxiomInstCo has a [TcCoercion] parameter, and not a [Type] parameter. This differs from the formalism, but corresponds to AxiomInstCo (see [Coercion axioms applied to coercions]). +-} -\begin{code} data TcCoercion = TcRefl Role TcType | TcTyConAppCo Role TyCon [TcCoercion] @@ -247,9 +243,7 @@ mkTcCoVarCo ipv = TcCoVarCo ipv -- the constraint solver does not substitute in the types of -- evidence variables as it goes. In any case, the optimisation -- will be done in the later zonking phase -\end{code} -\begin{code} tcCoercionKind :: TcCoercion -> Pair Type tcCoercionKind co = go co where @@ -342,11 +336,9 @@ coVarsOfTcCo tc_co get_bndrs :: Bag EvBind -> VarSet get_bndrs = foldrBag (\ (EvBind b _) bs -> extendVarSet bs b) emptyVarSet -\end{code} -Pretty printing +-- Pretty printing -\begin{code} instance Outputable TcCoercion where ppr = pprTcCo @@ -424,17 +416,15 @@ ppr_forall_co p ty (tvs, rho) = split1 [] ty split1 tvs (TcForAllCo tv ty) = split1 (tv:tvs) ty split1 tvs ty = (reverse tvs, ty) -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * HsWrapper -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data HsWrapper = WpHole -- The identity coercion @@ -477,14 +467,14 @@ c <.> WpHole = c c1 <.> c2 = c1 `WpCompose` c2 mkWpFun :: HsWrapper -> HsWrapper -> TcType -> TcType -> HsWrapper -mkWpFun WpHole WpHole _ _ = WpHole +mkWpFun WpHole WpHole _ _ = WpHole mkWpFun WpHole (WpCast co2) t1 _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) mkWpFun (WpCast co1) WpHole _ t2 = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) mkWpFun (WpCast co1) (WpCast co2) _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) mkWpFun co1 co2 t1 t2 = WpFun co1 co2 t1 t2 mkWpCast :: TcCoercion -> HsWrapper -mkWpCast co +mkWpCast co | isTcReflCo co = WpHole | otherwise = ASSERT2(tcCoercionRole co == Representational, ppr co) WpCast co @@ -523,16 +513,15 @@ idHsWrapper = WpHole isIdHsWrapper :: HsWrapper -> Bool isIdHsWrapper WpHole = True isIdHsWrapper _ = False -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Evidence bindings -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data TcEvBinds = TcEvBinds -- Mutable evidence bindings EvBindsVar -- Mutable because they are updated "later" @@ -609,8 +598,8 @@ data EvLit = EvNum Integer | EvStr FastString deriving( Data.Data, Data.Typeable) -\end{code} +{- Note [Coercion evidence terms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A "coercion evidence term" takes one of these forms @@ -699,14 +688,8 @@ The story for kind `Symbol` is analogous: * class KnownSymbol * newtype SSymbol * Evidence: EvLit (EvStr n) +-} - - - - - - -\begin{code} mkEvCast :: EvTerm -> TcCoercion -> EvTerm mkEvCast ev lco | ASSERT2(tcCoercionRole lco == Representational, (vcat [ptext (sLit "Coercion of wrong role passed to mkEvCast:"), ppr ev, ppr lco])) @@ -742,16 +725,15 @@ evVarsOfTerm (EvLit _) = emptyVarSet evVarsOfTerms :: [EvTerm] -> VarSet evVarsOfTerms = mapUnionVarSet evVarsOfTerm -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Pretty printing -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} instance Outputable HsWrapper where ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn @@ -766,7 +748,7 @@ pprHsWrapper doc wrap -- False <=> appears as body of let or lambda help it WpHole = it help it (WpCompose f1 f2) = help (help it f2) f1 - help it (WpFun f1 f2 t1 _) = add_parens $ ptext (sLit "\\(x") <> dcolon <> ppr t1 <> ptext (sLit ").") <+> + help it (WpFun f1 f2 t1 _) = add_parens $ ptext (sLit "\\(x") <> dcolon <> ppr t1 <> ptext (sLit ").") <+> help (\_ -> it True <+> help (\_ -> ptext (sLit "x")) f1 True) f2 False help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") <+> pprParendTcCo co)] @@ -809,5 +791,3 @@ instance Outputable EvTerm where instance Outputable EvLit where ppr (EvNum n) = integer n ppr (EvStr s) = text (show s) -\end{code} - diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.hs index a1d9b6a623..763be05922 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.hs @@ -1,10 +1,11 @@ +{- c% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + \section[TcExpr]{Typecheck an expression} +-} -\begin{code} {-# LANGUAGE CPP #-} module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, @@ -64,15 +65,15 @@ import Class(classTyCon) import Data.Function import Data.List import qualified Data.Set as Set -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Main wrappers} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcPolyExpr, tcPolyExprNC :: LHsExpr Name -- Expression to type check -> TcSigmaType -- Expected type (could be a polytype) @@ -137,16 +138,15 @@ tcHole occ res_ty , cc_hole = ExprHole } ; emitInsoluble can ; tcWrapResult (HsVar ev) ty res_ty } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * tcExpr: the main expression typechecker -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId) tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e) @@ -222,7 +222,7 @@ tcExpr (ExprWithTySig expr sig_ty wcs) res_ty -- Remember to extend the lexical type-variable environment -- See Note [More instantiated than scoped] in TcBinds - tcExtendTyVarEnv2 + tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- findScopedTyVars sig_ty sig_tc_ty skol_tvs] $ tcMonoExprNC expr res_ty @@ -243,14 +243,13 @@ tcExpr (HsType ty) _ -- same parser parses *patterns*. tcExpr (HsUnboundVar v) res_ty = tcHole (rdrNameOcc v) res_ty -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Infix operators and sections -%* * -%************************************************************************ +* * +************************************************************************ Note [Left sections] ~~~~~~~~~~~~~~~~~~~~ @@ -295,9 +294,8 @@ with a kind error. It seems more uniform to treat 'seq' as it it was a language construct. See Note [seqId magic] in MkId, and +-} - -\begin{code} tcExpr (OpApp arg1 op fix arg2) res_ty | (L loc (HsVar op_name)) <- op , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] @@ -422,15 +420,15 @@ tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Let, case, if, do -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcExpr (HsLet binds expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty @@ -488,8 +486,8 @@ tcExpr (HsDo do_or_lc stmts _) res_ty tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty ; return $ mkHsWrapCo coi (HsProc pat' cmd') } -\end{code} +{- Note [Rebindable syntax for if] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The rebindable syntax for 'if' uses the most flexible possible type @@ -507,13 +505,13 @@ to support expressions like this: else "No value" -%************************************************************************ -%* * +************************************************************************ +* * Record construction and update -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty = do { data_con <- tcLookupDataCon con_name @@ -529,8 +527,8 @@ tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty ; rbinds' <- tcRecordBinds data_con arg_tys rbinds ; return $ mkHsWrapCo co_res $ RecordCon (L loc con_id) con_expr rbinds' } -\end{code} +{- Note [Type of a record update] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The main complication with RecordUpd is that we need to explicitly @@ -631,8 +629,8 @@ In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): * in_inst_tys, out_inst_tys have same length, and instantiate the *representation* tycon of the data cons. In Note [Data family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] +-} -\begin{code} tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty = ASSERT( notNull upd_fld_names ) do { @@ -756,17 +754,17 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty , not (fld `elem` upd_fld_names)] , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs , tv `elemVarSet` fixed_tvs ] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Arithmetic sequences e.g. [a,b..] and their parallel-array counterparts e.g. [: a,b.. :] -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcExpr (ArithSeq _ witness seq) res_ty = tcArithSeq witness seq res_ty @@ -795,45 +793,42 @@ tcExpr (PArrSeq _ _) _ = panic "TcExpr.tcExpr: Infinite parallel array!" -- the parser shouldn't have generated it and the renamer shouldn't have -- let it through -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Template Haskell -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcExpr (HsSpliceE is_ty splice) res_ty = ASSERT( is_ty ) -- Untyped splices are expanded by the renamer tcSpliceExpr splice res_ty tcExpr (HsBracket brack) res_ty = tcTypedBracket brack res_ty tcExpr (HsRnBracketOut brack ps) res_ty = tcUntypedBracket brack ps res_ty -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Catch-all -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) -- Include ArrForm, ArrApp, which shouldn't appear at all -- Also HsTcBracketOut, HsQuasiQuoteE -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Arithmetic sequences [a..b] etc -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType -> TcM (HsExpr TcId) @@ -880,15 +875,15 @@ arithSeqEltType (Just fl) res_ty ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty) ; (coi, elt_ty) <- matchExpectedListTy list_ty ; return (coi, elt_ty, Just fl') } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Applications -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args @@ -996,9 +991,8 @@ tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId) tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op ; tcWrapResult expr rho res_ty } tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other) -\end{code} - +{- Note [Push result type in] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Unify with expected result before type-checking the args so that the @@ -1024,13 +1018,13 @@ the signature is propagated into MkQ's argument. With the check in the other order, the extra signature in f2 is reqd. -%************************************************************************ -%* * +************************************************************************ +* * tcInferId -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) tcCheckId name res_ty = do { (expr, actual_res_ty) <- tcInferId name @@ -1126,8 +1120,8 @@ srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr TcId srcSpanPrimLit dflags span = HsLit (HsStringPrim "" (unsafeMkByteString (showSDocOneLine dflags (ppr span)))) -\end{code} +{- Note [Adding the implicit parameter to 'assert'] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The typechecker transforms (assert e1 e2) to (assertError "Foo.hs:27" @@ -1162,8 +1156,8 @@ Usually that coercion is hidden inside the wrappers for constructors of F [Int] but here we have to do it explicitly. It's all grotesquely complicated. +-} -\begin{code} tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId) -- (seq e1 e2) :: res_ty @@ -1213,16 +1207,15 @@ tcTagToEnum loc fun_name arg res_ty = hang (ptext (sLit "Bad call to tagToEnum#") <+> ptext (sLit "at type") <+> ppr ty) 2 what -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Template Haskell checks -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} checkThLocalId :: Id -> TcM () #ifndef GHCI /* GHCI and TH is off */ -------------------------------------- @@ -1291,8 +1284,8 @@ polySpliceErr :: Id -> SDoc polySpliceErr id = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id) #endif /* GHCI */ -\end{code} +{- Note [Lifting strings] ~~~~~~~~~~~~~~~~~~~~~~ If we see $(... [| s |] ...) where s::String, we don't want to @@ -1312,11 +1305,11 @@ which show up as ATcIds rather than AGlobals. So we need to check for naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Record bindings} -%* * -%************************************************************************ +* * +************************************************************************ Game plan for record bindings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1333,9 +1326,8 @@ For each binding field = value the expected argument type. This extends OK when the field types are universally quantified. +-} - -\begin{code} tcRecordBinds :: DataCon -> [TcType] -- Expected type for each field @@ -1403,16 +1395,17 @@ checkMissingFields data_con rbinds field_strs field_strs = dataConStrictMarks data_con -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Errors and contexts} -%* * -%************************************************************************ +* * +************************************************************************ Boring and alphabetical: -\begin{code} +-} + addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a addExprErrCtxt expr = addErrCtxt (exprCtxt expr) @@ -1516,8 +1509,8 @@ badFieldsUpd rbinds data_cons map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) countTrue = length . filter id -\end{code} +{- Note [Finding the conflicting fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have @@ -1528,20 +1521,20 @@ and we see a record update Then we'd like to find the smallest subset of fields that no constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. We don't really want to report that no constructor has all of -{a0,a1,b0,b1}, because when there are hundreds of fields it's +{a0,a1,b0,b1}, because when there are hundreds of fields it's hard to see what was really wrong. We may need more than two fields, though; eg - data T = A { x,y :: Int, v::Int } - | B { y,z :: Int, v::Int } + data T = A { x,y :: Int, v::Int } + | B { y,z :: Int, v::Int } | C { z,x :: Int, v::Int } with update r { x=e1, y=e2, z=e3 }, we Finding the smallest subset is hard, so the code here makes -a decent stab, no more. See Trac #7989. +a decent stab, no more. See Trac #7989. +-} -\begin{code} naughtyRecordSel :: TcId -> SDoc naughtyRecordSel sel_id = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+> @@ -1569,4 +1562,3 @@ missingFields con fields <+> pprWithCommas ppr fields -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args)) -\end{code} diff --git a/compiler/typecheck/TcExpr.lhs-boot b/compiler/typecheck/TcExpr.hs-boot index 378a012f67..acd5d8a747 100644 --- a/compiler/typecheck/TcExpr.lhs-boot +++ b/compiler/typecheck/TcExpr.hs-boot @@ -1,21 +1,20 @@ -\begin{code} module TcExpr where import HsSyn ( HsExpr, LHsExpr ) import Name ( Name ) import TcType ( TcType, TcRhoType, TcSigmaType ) import TcRnTypes( TcM, TcId, CtOrigin ) -tcPolyExpr :: +tcPolyExpr :: LHsExpr Name -> TcSigmaType -> TcM (LHsExpr TcId) -tcMonoExpr, tcMonoExprNC :: +tcMonoExpr, tcMonoExprNC :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) -tcInferRho, tcInferRhoNC :: +tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) @@ -25,4 +24,3 @@ tcSyntaxOp :: CtOrigin -> TcM (HsExpr TcId) tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) -\end{code} diff --git a/compiler/typecheck/TcFlatten.lhs b/compiler/typecheck/TcFlatten.hs index 8c207522a2..10adc9432a 100644 --- a/compiler/typecheck/TcFlatten.lhs +++ b/compiler/typecheck/TcFlatten.hs @@ -1,4 +1,3 @@ -\begin{code} {-# LANGUAGE CPP #-} module TcFlatten( @@ -29,9 +28,8 @@ import Util import Bag import FastString import Control.Monad( when ) -\end{code} - +{- Note [The flattening story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * A CFunEqCan is either of form @@ -306,12 +304,12 @@ Current story: we don't generate these derived constraints. We could, but we'd want to make them very weak, so we didn't get the Int~Bool complaint. -%************************************************************************ -%* * -%* Other notes (Oct 14) +************************************************************************ +* * +* Other notes (Oct 14) I have not revisted these, but I didn't want to discard them -%* * -%************************************************************************ +* * +************************************************************************ Try: rewrite wanted with wanted only for fmvs (not all meta-tyvars) @@ -326,12 +324,12 @@ skol ~ untch, must re-orieint to untch ~ skol, so that we can use it to rewrite. -%************************************************************************ -%* * -%* Examples +************************************************************************ +* * +* Examples Here is a long series of examples I had to work through -%* * -%************************************************************************ +* * +************************************************************************ Simple20 ~~~~~~~~ @@ -343,7 +341,7 @@ axiom F [a] = [F a] [G] [F a] ~ fsk (nc) --> [G] F a ~ fsk2 - [G] fsk ~ [fsk2] + [G] fsk ~ [fsk2] [G] fsk ~ a --> [G] F a ~ fsk2 @@ -450,7 +448,7 @@ indexed-types/should_fail/GADTwrong1 work item fsk ~ () Surely the work item should rewrite to () ~ ()? Well, maybe not; -it'a very special case. More generally, our givens look like +it'a very special case. More generally, our givens look like F a ~ Int, where (F a) is not reducible. @@ -480,7 +478,7 @@ wanteds with wanteds. Then we go into a loop when normalise the work-item, because we use rewriteOrSame on the argument of V. -Conclusion: Don't make canRewrite context specific; instead use +Conclusion: Don't make canRewrite context specific; instead use [W] a ~ ty to rewrite a wanted iff 'a' is a unification variable. @@ -518,11 +516,11 @@ wanteds, we will [W] Int ~ Bool -%************************************************************************ -%* * -%* The main flattening functions -%* * -%************************************************************************ +************************************************************************ +* * +* The main flattening functions +* * +************************************************************************ Note [Flattening] ~~~~~~~~~~~~~~~~~~~~ @@ -563,8 +561,8 @@ so when the flattener encounters one, it first asks whether its transitive expansion contains any type function applications. If so, it expands the synonym and proceeds; if not, it simply returns the unexpanded synonym. +-} -\begin{code} data FlattenEnv = FE { fe_mode :: FlattenMode , fe_ev :: CtEvidence } @@ -580,8 +578,8 @@ data FlattenMode -- Postcondition for all three: inert wrt the type substitutio -- (but under type constructors is ok e.g. [F a]) | FM_SubstOnly -- See Note [Flattening under a forall] -\end{code} +{- Note [Lazy flattening] ~~~~~~~~~~~~~~~~~~~~~~ The idea of FM_Avoid mode is to flatten less aggressively. If we have @@ -607,8 +605,8 @@ other examples where lazy flattening caused problems. Bottom line: FM_Avoid is unused for now (Nov 14). Note: T5321Fun got faster when I disabled FM_Avoid T5837 did too, but it's pathalogical anyway +-} -\begin{code} -- Flatten a bunch of types all at once. flattenMany :: FlattenEnv -> [Type] -> TcS ([Xi], [TcCoercion]) -- Coercions :: Xi ~ Type @@ -649,7 +647,7 @@ flatten fmode (FunTy ty1 ty2) flatten fmode (TyConApp tc tys) - -- Expand type synonyms that mention type families + -- Expand type synonyms that mention type families -- on the RHS; see Note [Flattening synonyms] | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys , let expanded_ty = mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys' @@ -690,8 +688,8 @@ flattenTyConApp :: FlattenEnv -> TyCon -> [TcType] -> TcS (Xi, TcCoercion) flattenTyConApp fmode tc tys = do { (xis, cos) <- flattenMany fmode tys ; return (mkTyConApp tc xis, mkTcTyConAppCo Nominal tc cos) } -\end{code} +{- Note [Flattening synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Not expanding synonyms aggressively improves error messages, and @@ -727,13 +725,13 @@ because now the 'b' has escaped its scope. We'd have to flatten to (a ~ forall b. fsk b, forall b. F a b ~ fsk b) and we have not begun to think about how to make that work! -%************************************************************************ -%* * +************************************************************************ +* * Flattening a type-family application -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} flattenFamApp, flattenExactFamApp, flattenExactFamApp_fully :: FlattenEnv -> TyCon -> [TcType] -> TcS (Xi, TcCoercion) -- flattenFamApp can be over-saturated @@ -802,19 +800,19 @@ flattenExactFamApp_fully fmode tc tys ; traceTcS "flatten/flat-cache miss" $ (ppr fam_ty $$ ppr fsk $$ ppr ev) ; return (mkTyVarTy fsk, mkTcSymCo (ctEvCoercion ev) `mkTcTransCo` ret_co) } } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Flattening a type variable -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} flattenTyVar :: FlattenEnv -> TcTyVar -> TcS (Xi, TcCoercion) -- "Flattening" a type variable means to apply the substitution to it --- The substitution is actually the union of --- * the unifications that have taken place (either before the +-- The substitution is actually the union of +-- * the unifications that have taken place (either before the -- solver started, or in TcInteract.solveByUnification) -- * the CTyEqCans held in the inert set -- @@ -882,8 +880,8 @@ flattenTyVarFinal ctxt_ev tv kind_fmode = FE { fe_ev = ctxt_ev, fe_mode = FM_SubstOnly } ; (new_knd, _kind_co) <- flatten kind_fmode kind ; return (Left (setVarType tv new_knd)) } -\end{code} +{- Note [Applying the inert substitution] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The inert CTyEqCans (a ~ ty), inert_eqs, can be treated as a @@ -990,9 +988,8 @@ is an example; all the constraints here are Givens Because the incoming given rewrites all the inert givens, we get more and more duplication in the inert set. But this really only happens in pathalogical casee, so we don't care. +-} - -\begin{code} eqCanRewrite :: CtEvidence -> CtEvidence -> Bool -- Very important function! -- See Note [eqCanRewrite] @@ -1007,8 +1004,8 @@ canRewriteOrSame (CtWanted {}) (CtWanted {}) = True canRewriteOrSame (CtWanted {}) (CtDerived {}) = True canRewriteOrSame (CtDerived {}) (CtDerived {}) = True canRewriteOrSame _ _ = False -\end{code} +{- Note [eqCanRewrite] ~~~~~~~~~~~~~~~~~~~ (eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form @@ -1037,11 +1034,11 @@ canRewriteOrSame is similar but * works for all kinds of constraints, not just CTyEqCans See the call sites for explanations. -%************************************************************************ -%* * +************************************************************************ +* * Unflattening -%* * -%************************************************************************ +* * +************************************************************************ An unflattening example: [W] F a ~ alpha @@ -1049,9 +1046,8 @@ flattens to [W] F a ~ fmv (CFunEqCan) [W] fmv ~ alpha (CTyEqCan) We must solve both! +-} - -\begin{code} unflatten :: Cts -> Cts -> TcS Cts unflatten tv_eqs funeqs = do { dflags <- getDynFlags @@ -1160,8 +1156,8 @@ tryFill dflags tv rhs ev _ -> -- Occurs check return False } } -\end{code} +{- Note [Unflatten using funeqs first] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ [W] G a ~ Int @@ -1178,4 +1174,4 @@ unsolved constraints. The flat form will be fmv1 ~ fmv2 (CTyEqCan) Flatten using the fun-eqs first. - +-} diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.hs index 73b3b1cf65..b38716231a 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.hs @@ -1,7 +1,7 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + \section[TcForeign]{Typechecking \tr{foreign} declarations} A foreign declaration is used to either give an externally @@ -10,8 +10,8 @@ give a Haskell function an external calling interface. Either way, the range of argument and result types these functions can accommodate is restricted to what the outside world understands (read C), and this module checks to see if a foreign declaration has got a legal type. +-} -\begin{code} {-# LANGUAGE CPP #-} module TcForeign @@ -62,9 +62,7 @@ import FastString import Hooks import Control.Monad -\end{code} -\begin{code} -- Defines a binding isForeignImport :: LForeignDecl name -> Bool isForeignImport (L _ (ForeignImport _ _ _ _)) = True @@ -74,8 +72,8 @@ isForeignImport _ = False isForeignExport :: LForeignDecl name -> Bool isForeignExport (L _ (ForeignExport _ _ _ _)) = True isForeignExport _ = False -\end{code} +{- Note [Don't recur in normaliseFfiType'] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ normaliseFfiType' is the workhorse for normalising a type used in a foreign @@ -107,8 +105,8 @@ IO and FunPtr. Thus, this is not an onerous burden. If we ever want to lift this restriction, we would need to make 'go' take the target role as a parameter. This wouldn't be hard, but it's a complication not yet necessary and so is not yet implemented. +-} -\begin{code} -- normaliseFfiType takes the type from an FFI declaration, and -- evaluates any type synonyms, type functions, and newtypes. However, -- we are only allowed to look through newtypes if the constructor is @@ -142,7 +140,7 @@ normaliseFfiType' env ty0 = go initRecTc ty0 -- Here, we don't reject the type for being recursive. -- If this is a recursive newtype then it will normally -- be rejected later as not being a valid FFI type. - = do { rdr_env <- getGlobalRdrEnv + = do { rdr_env <- getGlobalRdrEnv ; case checkNewtypeFFI rdr_env tc of Nothing -> nothing Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs @@ -152,7 +150,7 @@ normaliseFfiType' env ty0 = go initRecTc ty0 , (co, ty) <- normaliseTcApp env Representational tc tys , not (isReflCo co) = do (co', ty', gres) <- go rec_nts ty - return (mkTransCo co co', ty', gres) + return (mkTransCo co co', ty', gres) | otherwise = nothing -- see Note [Don't recur in normaliseFfiType'] @@ -186,18 +184,18 @@ normaliseFfiType' env ty0 = go initRecTc ty0 -- See Note [Don't recur in normaliseFfiType'] checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt -checkNewtypeFFI rdr_env tc +checkNewtypeFFI rdr_env tc | Just con <- tyConSingleDataCon_maybe tc , [gre] <- lookupGRE_Name rdr_env (dataConName con) = Just gre -- See Note [Newtype constructor usage in foreign declarations] | otherwise = Nothing -\end{code} +{- Note [Newtype constructor usage in foreign declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC automatically "unwraps" newtype constructors in foreign import/export -declarations. In effect that means that a newtype data constructor is +declarations. In effect that means that a newtype data constructor is used even though it is not mentioned expclitly in the source, so we don't want to report it as "defined but not used" or "imported but not used". eg newtype D = MkD Int @@ -205,30 +203,30 @@ eg newtype D = MkD Int Here 'MkD' us used. See Trac #7408. GHC also expands type functions during this process, so it's not enough -just to look at the free variables of the declaration. +just to look at the free variables of the declaration. eg type instance F Bool = D foreign import bar :: F Bool -> IO () Here again 'MkD' is used. So we really have wait until the type checker to decide what is used. That's why tcForeignImports and tecForeignExports return a (Bag GRE) -for the newtype constructors they see. Then TcRnDriver can add them +for the newtype constructors they see. Then TcRnDriver can add them to the module's usages. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Imports} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt) tcForeignImports decls = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls) tcForeignImports' :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt) --- For the (Bag GlobalRdrElt) result, +-- For the (Bag GlobalRdrElt) result, -- see Note [Newtype constructor usage in foreign declarations] tcForeignImports' decls = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $ @@ -256,11 +254,9 @@ tcFImport (L dloc fo@(ForeignImport (L nloc nm) hs_ty _ imp_decl)) ; let fi_decl = ForeignImport (L nloc id) undefined (mkSymCo norm_co) imp_decl' ; return (id, L dloc fi_decl, gres) } tcFImport d = pprPanic "tcFImport" (ppr d) -\end{code} +-- ------------ Checking types for foreign import ---------------------- ------------- Checking types for foreign import ---------------------- -\begin{code} tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src) @@ -294,7 +290,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh checkCg checkCOrAsmOrLlvmOrInterp cconv' <- checkCConv cconv case arg_tys of -- The first arg must be Ptr or FunPtr - [] -> + [] -> addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "At least one argument expected"))) (arg1_ty:arg_tys) -> do dflags <- getDynFlags @@ -349,15 +345,15 @@ checkMissingAmpersand dflags arg_tys res_ty = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr")) | otherwise = return () -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Exports} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcForeignExports :: [LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt) tcForeignExports decls = @@ -365,7 +361,7 @@ tcForeignExports decls = tcForeignExports' :: [LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt) --- For the (Bag GlobalRdrElt) result, +-- For the (Bag GlobalRdrElt) result, -- see Note [Newtype constructor usage in foreign declarations] tcForeignExports' decls = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) @@ -397,11 +393,9 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec', gres) tcFExport d = pprPanic "tcFExport" (ppr d) -\end{code} ------------- Checking argument types for foreign export ---------------------- +-- ------------ Checking argument types for foreign export ---------------------- -\begin{code} tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport tcCheckFEType sig_ty (CExport (L l (CExportStatic str cconv)) src) = do checkCg checkCOrAsmOrLlvm @@ -415,17 +409,15 @@ tcCheckFEType sig_ty (CExport (L l (CExportStatic str cconv)) src) = do -- the structure of the foreign type. (_, t_ty) = tcSplitForAllTys sig_ty (arg_tys, res_ty) = tcSplitFunTys t_ty -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Miscellaneous} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} ------------ Checking argument types for foreign import ---------------------- checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM () checkForeignArgs pred tys = mapM_ go tys @@ -437,7 +429,7 @@ checkForeignArgs pred tys = mapM_ go tys -- (IO t) or (t) , and that t satisfies the given predicate. -- When calling this function, any newtype wrappers (should) have been -- already dealt with by normaliseFfiType. --- +-- -- We also check that the Safe Haskell condition of FFI imports having -- results in the IO monad holds. -- @@ -478,11 +470,9 @@ mustBeIO = False checkSafe, noCheckSafe :: Bool checkSafe = True noCheckSafe = False -\end{code} -Checking a supported backend is in use +-- Checking a supported backend is in use -\begin{code} checkCOrAsmOrLlvm :: HscTarget -> Validity checkCOrAsmOrLlvm HscC = IsValid checkCOrAsmOrLlvm HscAsm = IsValid @@ -508,11 +498,9 @@ checkCg check = do case check target of IsValid -> return () NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) -\end{code} -Calling conventions +-- Calling conventions -\begin{code} checkCConv :: CCallConv -> TcM CCallConv checkCConv CCallConv = return CCallConv checkCConv CApiConv = return CApiConv @@ -531,11 +519,9 @@ checkCConv JavaScriptCallConv = do dflags <- getDynFlags then return JavaScriptCallConv else do addErrTc (text "The `javascript' calling convention is unsupported on this platform") return JavaScriptCallConv -\end{code} -Warnings +-- Warnings -\begin{code} check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () check IsValid _ = return () check (NotValid doc) err_fn = addErrTc (err_fn doc) @@ -560,4 +546,3 @@ foreignDeclCtxt :: ForeignDecl Name -> SDoc foreignDeclCtxt fo = hang (ptext (sLit "When checking declaration:")) 2 (ppr fo) -\end{code} diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.hs index 13d8e836f6..57adb1ccab 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -1,7 +1,8 @@ +{- % -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + TcGenDeriv: Generating derived instance declarations @@ -9,8 +10,8 @@ This module is nominally ``subordinate'' to @TcDeriv@, which is the ``official'' interface to deriving-related things. This is where we do all the grimy bindings' generation. +-} -\begin{code} {-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} @@ -70,9 +71,7 @@ import StaticFlags( opt_PprStyle_Debug ) import ListSetOps ( assocMaybe ) import Data.List ( partition, intersperse ) import Data.Maybe ( isNothing ) -\end{code} -\begin{code} type BagDerivStuff = Bag DerivStuff data AuxBindSpec @@ -93,15 +92,15 @@ data DerivStuff -- Please add this auxiliary stuff -- New top-level auxiliary bindings | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB | DerivInst (InstInfo RdrName) -- New, auxiliary instances -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Top level function -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) genDerivedBinds dflags fix_env clas loc tycon @@ -143,13 +142,13 @@ canDeriveAnyClass dflags _tycon clas = (not (getUnique clas `elem` standardClassKeys) `orElse` "") -- 2) Opt_DeriveAnyClass is on <> (xopt Opt_DeriveAnyClass dflags `orElse` "Try enabling DeriveAnyClass") -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Eq instances -%* * -%************************************************************************ +* * +************************************************************************ Here are the heuristics for the code we generate for @Eq@. Let's assume we have a data type with some (possibly zero) nullary data @@ -201,8 +200,8 @@ tycon, we generate: However, that requires that (Ord <whatever>) was put in the context for the instance decl, which it probably wasn't, so the decls produced don't get through the typechecker. +-} -\begin{code} gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Eq_binds loc tycon = (method_binds, aux_binds) @@ -261,13 +260,13 @@ gen_Eq_binds loc tycon = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) where nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b)) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Ord instances -%* * -%************************************************************************ +* * +************************************************************************ Note [Generating Ord instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -330,8 +329,8 @@ binary result, something like this: So for sufficiently small types (few constructors, or all nullary) we generate all methods; for large ones we just use 'compare'. +-} -\begin{code} data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT ------------ @@ -549,15 +548,13 @@ nlConWildPat :: DataCon -> LPat RdrName nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con)) (RecCon (HsRecFields { rec_flds = [] , rec_dotdot = Nothing }))) -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * Enum instances -%* * -%************************************************************************ +* * +************************************************************************ @Enum@ can only be derived for enumeration types. For a type \begin{verbatim} @@ -593,8 +590,8 @@ instance ... Enum (Foo ...) where \end{verbatim} For @enumFromTo@ and @enumFromThenTo@, we use the default methods. +-} -\begin{code} gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Enum_binds loc tycon = (method_binds, aux_binds) @@ -666,15 +663,15 @@ gen_Enum_binds loc tycon = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Bounded instances -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Bounded_binds loc tycon | isEnumerationTyCon tycon @@ -701,13 +698,13 @@ gen_Bounded_binds loc tycon nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) max_bound_1con = mkHsVarBind loc maxBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Ix instances -%* * -%************************************************************************ +* * +************************************************************************ Deriving @Ix@ is only possible for enumeration types and single-constructor types. We deal with them in turn. @@ -760,8 +757,8 @@ For a single-constructor type (NB: this includes all tuples), e.g., \end{verbatim} we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). +-} -\begin{code} gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Ix_binds loc tycon @@ -876,13 +873,13 @@ gen_Ix_binds loc tycon foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed) where in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Read instances -%* * -%************************************************************************ +* * +************************************************************************ Example @@ -949,8 +946,8 @@ Rather we want Because 'pfail' allows the parser to backtrack, but 'error' doesn't. These instances are also useful for Read (Either Int Emp), where we want to be able to parse (Left 3) just fine. +-} -\begin{code} gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Read_binds get_fixity loc tycon @@ -1087,14 +1084,13 @@ gen_Read_binds get_fixity loc tycon = ident_h_pat lbl_str where lbl_str = occNameString (getOccName lbl) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Show instances -%* * -%************************************************************************ +* * +************************************************************************ Example @@ -1118,8 +1114,8 @@ Example up_prec = 5 -- Precedence of :^: app_prec = 10 -- Application has precedence one more than -- the most tightly-binding operator +-} -\begin{code} gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Show_binds get_fixity loc tycon @@ -1213,9 +1209,7 @@ isSym (c : _) = startsVarSym c || startsConSym c mk_showString_app :: String -> LHsExpr RdrName mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) -\end{code} -\begin{code} getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer getPrec is_infix get_fixity nm | not is_infix = appPrecedence @@ -1233,14 +1227,13 @@ getPrecedence get_fixity nm -- NB: the Report says that associativity is not taken -- into account for either Read or Show; hence we -- ignore associativity here -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Typeable (new)} -%* * -%************************************************************************ +* * +************************************************************************ From the data type @@ -1253,8 +1246,8 @@ we generate <pkg> <module> "T") [] We are passed the Typeable2 class as well as T +-} -\begin{code} gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Typeable_binds dflags loc tycon @@ -1283,15 +1276,13 @@ gen_Typeable_binds dflags loc tycon int64 | wORD_SIZE dflags == 4 = HsWord64Prim "" . fromIntegral | otherwise = HsWordPrim "" . fromIntegral -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * Data instances -%* * -%************************************************************************ +* * +************************************************************************ From the data type @@ -1320,9 +1311,8 @@ we generate dataCast1 = gcast1 -- If T :: * -> * dataCast2 = gcast2 -- if T :: * -> * -> * +-} - -\begin{code} gen_Data_binds :: DynFlags -> SrcSpan -> TyCon -- For data families, this is the @@ -1512,18 +1502,16 @@ ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" ) leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##") gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * Functor instances see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html -%* * -%************************************************************************ +* * +************************************************************************ For the data type: @@ -1600,8 +1588,8 @@ lambda functions by producing a meta level function. But the function to be mapped, `f`, is a function on the code level, not on the meta level, so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion. It is better to produce too many lambdas than to eta expand, see ticket #7436. +-} -\begin{code} gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Functor_binds loc tycon = (unitBag fmap_bind, emptyBag) @@ -1637,14 +1625,14 @@ gen_Functor_binds loc tycon -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) match_for_con = mkSimpleConMatch $ \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 .. -\end{code} +{- Utility functions related to Functor deriving. Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse. This function works like a fold: it makes a value of type 'a' in a bottom up way. +-} -\begin{code} -- Generic traversal for Functor deriving data FFoldType a -- Describes how to fold over a Type in a functor like way = FT { ft_triv :: a -- Does not contain variable @@ -1763,17 +1751,16 @@ mkSimpleTupleCase match_for_con sort insides x = do let con = tupleCon sort (length insides) match <- match_for_con [] con insides return $ nlHsCase x [match] -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Foldable instances see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html -%* * -%************************************************************************ +* * +************************************************************************ Deriving Foldable instances works the same way as Functor instances, only Foldable instances are not possible for function types at all. @@ -1791,8 +1778,8 @@ The cases are: Note that the arguments to the real foldr function are the wrong way around, since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). +-} -\begin{code} gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Foldable_binds loc tycon = (listToBag [foldr_bind, foldMap_bind], emptyBag) @@ -1840,16 +1827,14 @@ gen_Foldable_binds loc tycon [] -> mempty_Expr xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * Traversable instances see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html -%* * -%************************************************************************ +* * +************************************************************************ Again, Traversable is much like Functor and Foldable. @@ -1866,8 +1851,8 @@ Note that the generated code is not as efficient as it could be. For instance: gives the function: traverse f (T x y) = T <$> pure x <*> f y instead of: traverse f (T x y) = T x <$> f y +-} -\begin{code} gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Traversable_binds loc tycon = (unitBag traverse_bind, emptyBag) @@ -1901,13 +1886,13 @@ gen_Traversable_binds loc tycon mkApCon con [] = nlHsApps pure_RDR [con] mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs where appAp x y = nlHsApps ap_RDR [x,y] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Newtype-deriving instances -%* * -%************************************************************************ +* * +************************************************************************ We take every method in the original instance and `coerce` it to fit into the derived instance. We need a type annotation on the argument @@ -1915,8 +1900,8 @@ to `coerce` to make it obvious what instantiation of the method we're coercing from. See #8503 for more discussion. +-} -\begin{code} mkCoerceClassMethEqn :: Class -- the class being derived -> [TyVar] -- the tvs in the instance head -> [Type] -- instance head parameters (incl. newtype) @@ -1966,13 +1951,13 @@ gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty nlExprWithTySig :: LHsExpr RdrName -> LHsType RdrName -> LHsExpr RdrName nlExprWithTySig e s = noLoc (ExprWithTySig e s PlaceHolder) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Generating extra binds (@con2tag@ and @tag2con@)} -%* * -%************************************************************************ +* * +************************************************************************ \begin{verbatim} data Foo ... = ... @@ -1984,8 +1969,8 @@ maxtag_Foo :: Int -- ditto (NB: not unlifted) The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) fiddling around. +-} -\begin{code} genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName) genAuxBindSpec loc (DerivCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, @@ -2076,16 +2061,15 @@ mkParentType tc = case tyConFamInst_maybe tc of Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc)) Just (fam_tc,tys) -> mkTyConApp fam_tc tys -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Utility bits for generating bindings} -%* * -%************************************************************************ - +* * +************************************************************************ +-} -\begin{code} mk_FunBind :: SrcSpan -> RdrName -> [([LPat RdrName], LHsExpr RdrName)] -> LHsBind RdrName @@ -2106,9 +2090,7 @@ mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') then [mkMatch [] (error_Expr str) emptyLocalBinds] else matches str = "Void " ++ occNameString (rdrNameOcc fun_rdr) -\end{code} -\begin{code} box_if_necy :: String -- The class involved -> TyCon -- The tycon involved -> LHsExpr RdrName -- The argument @@ -2172,9 +2154,7 @@ eq_Expr tycon ty a b | otherwise = genPrimOpApp a prim_eq b where (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty -\end{code} -\begin{code} untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName untag_Expr _ [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr @@ -2246,9 +2226,7 @@ genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2)) -\end{code} -\begin{code} a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR :: RdrName a_RDR = mkVarUnqual (fsLit "a") @@ -2324,8 +2302,8 @@ mkAuxBinderName parent occ_fun parent_uniq = nameUnique parent parent_occ = nameOccName parent -\end{code} +{- Note [Auxiliary binders] ~~~~~~~~~~~~~~~~~~~~~~~~ We often want to make a top-level auxiliary binding. E.g. for comparison we haev @@ -2347,3 +2325,4 @@ OccName we generate for the new binding. In the past we used mkDerivedRdrName name occ_fun, which made an original name But: (a) that does not work well for standalone-deriving either (b) an unqualified name is just fine, provided it can't clash with user code +-} diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.hs index 5bb0862de1..b4f9ae08ac 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2011 -% +{- +(c) The University of Glasgow 2011 + The deriving code for the Generic class (equivalent to the code in TcGenDeriv, for other classes) +-} -\begin{code} {-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} @@ -48,13 +48,13 @@ import Util import Control.Monad (mplus,forM) #include "HsVersions.h" -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Bindings for the new generic deriving mechanism} -%* * -%************************************************************************ +* * +************************************************************************ For the generic representation we need to generate: \begin{itemize} @@ -62,8 +62,8 @@ For the generic representation we need to generate: \item A Rep type instance \item Many auxiliary datatypes and instances for them (for the meta-information) \end{itemize} +-} -\begin{code} gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module -> TcM (LHsBinds RdrName, FamInst) gen_Generic_binds gk tc metaTyCons mod = do @@ -178,15 +178,15 @@ metaTyConsToDerivStuff tc metaDts = return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts) `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Generating representation types} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} get_gen1_constrained_tys :: TyVar -> Type -> [Type] -- called by TcDeriv.inferConstraints; generates a list of types, each of which -- must be a Functor in order for the Generic1 instance to work. @@ -396,15 +396,14 @@ canDoGenerics1 rep_tc tc_args = wrong_arg = text "applies a type to an argument involving the last parameter" $$ text "but the applied type is not of kind * -> *" -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Generating the RHS of a generic default method} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} type US = Int -- Local unique supply, just a plain Int type Alt = (LPat RdrName, LHsExpr RdrName) @@ -882,5 +881,3 @@ foldBal' _ x [] = x foldBal' _ _ [y] = y foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l in foldBal' op x a `op` foldBal' op x b - -\end{code} diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.hs index 4d4484cfa9..8ad8fe2ca0 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.hs @@ -1,14 +1,14 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1996-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker This module is an extension of @HsSyn@ syntax, for use in the type checker. +-} -\begin{code} {-# LANGUAGE CPP #-} module TcHsSyn ( @@ -61,17 +61,18 @@ import Util #if __GLASGOW_HASKELL__ < 709 import Data.Traversable ( traverse ) #endif -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[mkFailurePair]{Code for pattern-matching and other failures} -%* * -%************************************************************************ +* * +************************************************************************ Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@, then something is wrong. -\begin{code} +-} + hsLPatType :: OutPat Id -> Type hsLPatType (L _ pat) = hsPatType pat @@ -114,11 +115,9 @@ hsLitType (HsInteger _ _ ty) = ty hsLitType (HsRat _ ty) = ty hsLitType (HsFloatPrim _) = floatPrimTy hsLitType (HsDoublePrim _) = doublePrimTy -\end{code} -Overloaded literals. Here mainly because it uses isIntTy etc +-- Overloaded literals. Here mainly because it uses isIntTy etc -\begin{code} shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId) shortCutLit dflags (HsIntegral src i) ty | isIntTy ty && inIntRange dflags i = Just (HsLit (HsInt src i)) @@ -150,13 +149,13 @@ hsOverLitName :: OverLitVal -> Name hsOverLitName (HsIntegral {}) = fromIntegerName hsOverLitName (HsFractional {}) = fromRationalName hsOverLitName (HsIsString {}) = fromStringName -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} -%* * -%************************************************************************ +* * +************************************************************************ The rest of the zonking is done *after* typechecking. The main zonking pass runs over the bindings @@ -174,8 +173,8 @@ all occurrences of that Id point to the common zonked copy It's all pretty boring stuff, because HsSyn is such a large type, and the environment manipulation is tiresome. +-} -\begin{code} type UnboundTyVarZonker = TcTyVar-> TcM Type -- How to zonk an unbound type variable -- Note [Zonking the LHS of a RULE] @@ -290,10 +289,7 @@ zonkTyBndrX env tv = do { ki <- zonkTcTypeToType env (tyVarKind tv) ; let tv' = mkTyVar (tyVarName tv) ki ; return (extendTyZonkEnv1 env tv', tv') } -\end{code} - -\begin{code} zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id) zonkTopExpr e = zonkExpr emptyZonkEnv e @@ -523,15 +519,15 @@ zonkLTcSpecPrags env ps zonk_prag (L loc (SpecPrag id co_fn inl)) = do { (_, co_fn') <- zonkCoFn env co_fn ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[BackSubst-Match-GRHSs]{Match and GRHSs} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} zonkMatchGroup :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id))) @@ -563,15 +559,15 @@ zonkGRHSs env zBody (GRHSs grhss binds) = do return (GRHS new_guarded new_rhs) new_grhss <- mapM (wrapLocM zonk_grhs) grhss return (GRHSs new_grhss new_binds) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id] zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id) zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id) @@ -999,16 +995,15 @@ mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b) mapIPNameTc _ (Left x) = return (Left x) mapIPNameTc f (Right x) = do r <- f x return (Right r) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[BackSubst-Pats]{Patterns} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id) -- Extend the environment as we go, because it's possible for one -- pattern to bind something that is used in another (inside or @@ -1144,16 +1139,15 @@ zonkPats env [] = return (env, []) zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat ; (env', pats') <- zonkPats env1 pats ; return (env', pat':pats') } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[BackSubst-Foreign]{Foreign exports} -%* * -%************************************************************************ - +* * +************************************************************************ +-} -\begin{code} zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id] zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls @@ -1162,9 +1156,7 @@ zonkForeignExport env (ForeignExport i _hs_ty co spec) = return (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec) zonkForeignExport _ for_imp = return for_imp -- Foreign imports don't need zonking -\end{code} -\begin{code} zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id] zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs @@ -1202,9 +1194,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) -- DV: used to be return (env,v) but that is plain -- wrong because we may need to go inside the kind -- of v and zonk there! -\end{code} -\begin{code} zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] zonkVects env = mapM (wrapLocM (zonkVect env)) @@ -1227,15 +1217,15 @@ zonkVect _ (HsVectClassIn _) = panic "TcHsSyn.zonkVect: HsVectClassIn" zonkVect _env (HsVectInstOut i) = return $ HsVectInstOut i zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn" -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Constraints and evidence -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) return (EvId (zonkIdOcc env v)) @@ -1294,13 +1284,13 @@ zonkEvBind env (EvBind var term) -> return (EvBind var' (EvCoercion (mkTcReflCo r ty1))) _other -> do { term' <- zonkEvTerm env term ; return (EvBind var' term') } } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Zonking types -%* * -%************************************************************************ +* * +************************************************************************ Note [Zonking the LHS of a RULE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1362,8 +1352,8 @@ use Refl on the right, ignoring the actual coercion on the RHS. This can have a very big effect, because the constraint solver sometimes does go to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf Trac #5030) +-} -\begin{code} zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv | isTcTyVar tv @@ -1485,4 +1475,3 @@ zonkTcCoToCo env co ; cs' <- mapM go cs ; return (TcAxiomRuleCo co ts' cs') } -\end{code} diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.hs index 62611a31a4..44ba79b73d 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + \section[TcMonoType]{Typechecking user-specified @MonoTypes@} +-} -\begin{code} {-# LANGUAGE CPP #-} module TcHsType ( @@ -70,9 +70,8 @@ import Util import Data.Maybe( isNothing ) import Control.Monad ( unless, when, zipWithM ) import PrelNames( ipClassName, funTyConKey, allNameStrings ) -\end{code} - +{- ---------------------------- General notes ---------------------------- @@ -149,13 +148,13 @@ knot around type declarations with ARecThing, so that the fault-in code can get the TyCon being defined. -%************************************************************************ -%* * +************************************************************************ +* * Check types AND do validity checking -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type -- NB: it's important that the foralls that come from the top-level -- HsForAllTy in hs_ty occur *first* in the returned type. @@ -231,22 +230,22 @@ tcHsVectInst ty ; return (cls, arg_tys) } | otherwise = failWithTc $ ptext (sLit "Malformed instance type") -\end{code} +{- These functions are used during knot-tying in type and class declarations, when we have to separate kind-checking, desugaring, and validity checking -%************************************************************************ -%* * +************************************************************************ +* * The main kind checker: no validity checks here -%* * -%************************************************************************ +* * +************************************************************************ First a couple of simple wrappers for kcHsType +-} -\begin{code} tcClassSigType :: LHsType Name -> TcM Type tcClassSigType lhs_ty@(L _ hs_ty) = addTypeCtxt lhs_ty $ @@ -305,14 +304,14 @@ tcCheckHsTypeAndGen hs_ty kind ; kvs <- zonkTcTypeAndFV ty ; kvs <- kindGeneralize kvs ; return (mkForAllTys kvs ty) } -\end{code} +{- Like tcExpr, tc_hs_type takes an expected kind which it unifies with the kind it figures out. When we don't know what kind to expect, we use tc_lhs_type_fresh, to first create a new meta kind variable and use that as the expected kind. +-} -\begin{code} tc_infer_lhs_type :: LHsType Name -> TcM (TcType, TcKind) tc_infer_lhs_type ty = do { kv <- newMetaKindVar @@ -428,7 +427,7 @@ tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind@(EK exp_k = traceTc "tc_hs_type tuple" (ppr hs_tys) >> tc_tuple hs_ty tup_sort hs_tys exp_kind | otherwise - = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) + = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) ; (tys, kinds) <- mapAndUnzipM tc_infer_lhs_type hs_tys ; kinds <- mapM zonkTcKind kinds -- Infer each arg type separately, because errors can be @@ -692,8 +691,8 @@ aThingErr :: String -> Name -> b -- do *kind* checking; and in that case it ignores the type -- returned. Which is a good thing since it may not be available yet! aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x) -\end{code} +{- Note [Zonking inside the knot] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we are checking the argument types of a data constructor. We @@ -723,8 +722,8 @@ look at the TyCon or Class involved. This is horribly delicate. I hate it. A good example of how delicate it is can be seen in Trac #7903. +-} -\begin{code} mkNakedTyConApp :: TyCon -> [Type] -> Type -- Builds a TyConApp -- * without being strict in TyCon, @@ -772,8 +771,8 @@ zonkSigType ty go (ForAllTy tv ty) = do { tv' <- zonkTcTyVarBndr tv ; ty' <- go ty ; return (ForAllTy tv' ty') } -\end{code} +{- Note [Body kind of a forall] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The body of a forall is usually a type, but in principle @@ -890,8 +889,8 @@ want to default it to '*', not to AnyK. Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-} -\begin{code} addTypeCtxt :: LHsType Name -> TcM a -> TcM a -- Wrap a context around only if we want to show that contexts. -- Omit invisble ones and ones user's won't grok @@ -899,15 +898,14 @@ addTypeCtxt (L _ ty) thing = addErrCtxt doc thing where doc = ptext (sLit "In the type") <+> quotes (ppr ty) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Type-variable binders -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} mkKindSigVar :: Name -> TcM KindVar -- Use the specified name; don't clone it @@ -1030,8 +1028,8 @@ kindGeneralize tkvs -- When typechecking the body of the bracket, we typecheck $t to a -- unification variable 'alpha', with no biding forall. We don't -- want to kind-quantify it! -\end{code} +{- Note [Kind generalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~ We do kind generalisation only at the outer level of a type signature. @@ -1066,8 +1064,8 @@ which the type checker will then instantiate, and instantiate does not look through unification variables! Hence using zonked_kinds when forming tvs'. +-} -\begin{code} -------------------- -- getInitialKind has made a suitably-shaped kind for the type or class -- Unpack it, and attribute those kinds to the type variables @@ -1179,8 +1177,8 @@ badKindSig :: Kind -> SDoc badKindSig kind = hang (ptext (sLit "Kind signature on data type declaration has non-* return kind")) 2 (ppr kind) -\end{code} +{- Note [Avoid name clashes for associated data types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider class C a b where @@ -1198,11 +1196,11 @@ important only to get nice-looking output when doing ":info C" in GHCi. It isn't essential for correctness. -%************************************************************************ -%* * +************************************************************************ +* * Scoped type variables -%* * -%************************************************************************ +* * +************************************************************************ tcAddScopedTyVars is used for scoped type variables added by pattern @@ -1236,8 +1234,8 @@ Historical note: we unify with it too early and checkSigTyVars barfs Instead you have to pass in a fresh ty var, and unify it with expected_ty afterwards +-} -\begin{code} tcHsPatSigType :: UserTypeCtxt -> HsWithBndrs Name (LHsType Name) -- The type signature -> TcM ( Type -- The signature @@ -1334,8 +1332,8 @@ patBindSigErr sig_tvs = hang (ptext (sLit "You cannot bind scoped type variable") <> plural sig_tvs <+> pprQuotedList (map fst sig_tvs)) 2 (ptext (sLit "in a pattern binding signature")) -\end{code} +{- Note [Pattern signature binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1379,19 +1377,19 @@ I think we could solve this by recording in a SigTv a list of all the in-scope varaibles that it should not unify with, but it's fiddly. -%************************************************************************ -%* * +************************************************************************ +* * Checking kinds -%* * -%************************************************************************ +* * +************************************************************************ We would like to get a decent error message from (a) Under-applied type constructors f :: (Maybe, Maybe) (b) Over-applied type constructors f :: Int x -> Int x +-} -\begin{code} -- The ExpKind datatype means "expected kind" and contains -- some info about just why that kind is expected, to improve -- the error message on a mis-match @@ -1515,20 +1513,19 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) ; traceTc "checkExpectedKind 1" (ppr ty $$ ppr tidy_act_kind $$ ppr tidy_exp_kind $$ ppr env1 $$ ppr env2) ; failWithTcM (env2, err) } } } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Sort checking kinds -%* * -%************************************************************************ +* * +************************************************************************ tcLHsKind converts a user-written kind to an internal, sort-checked kind. It does sort checking and desugaring at the same time, in one single pass. It fails when the kinds are not well-formed (eg. data A :: * Int), or if there are non-promotable or non-fully applied kinds. +-} -\begin{code} tcLHsKind :: LHsKind Name -> TcM Kind tcLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ tc_lhs_kind k @@ -1642,15 +1639,15 @@ promotionErr name err FamDataConPE -> ptext (sLit "it comes from a data family instance") NoDataKinds -> ptext (sLit "Perhaps you intended to use DataKinds") _ -> ptext (sLit "it is defined and used in the same recursive group") -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Scoped type variables -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} badPatSigTvs :: TcType -> [TyVar] -> SDoc badPatSigTvs sig_ty bad_tvs = vcat [ fsep [ptext (sLit "The type variable") <> plural bad_tvs, @@ -1669,5 +1666,3 @@ unifyKindMisMatch ki1 ki2 = do ptext (sLit "against"), quotes (ppr ki2')]) failWithTc msg -\end{code} - diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.hs index 553af7358c..3b182de917 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + TcInstDecls: Typechecking instance declarations +-} -\begin{code} {-# LANGUAGE CPP #-} module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where @@ -62,8 +62,8 @@ import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) import Control.Monad import Maybes ( isNothing, isJust, whenIsJust ) import Data.List ( mapAccumL, partition ) -\end{code} +{- Typechecking instance declarations is done in two passes. The first pass, made by @tcInstDecls1@, collects information to be used in the second pass. @@ -346,15 +346,15 @@ complained if 'b' is mentioned in <rhs>. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Extracting instance decls} -%* * -%************************************************************************ +* * +************************************************************************ Gather up the instance declarations from their various sources +-} -\begin{code} tcInstDecls1 -- Deal with both source-code and imported instance decls :: [LTyClDecl Name] -- For deriving stuff -> [LInstDecl Name] -- Source code instance decls @@ -469,8 +469,8 @@ addFamInsts fam_insts thing_inside axioms = map (toBranchedAxiom . famInstAxiom) fam_insts tycons = famInstsRepTyCons fam_insts things = map ATyCon tycons ++ map ACoAxiom axioms -\end{code} +{- Note [Deriving inside TH brackets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given a declaration bracket @@ -486,9 +486,8 @@ The easy solution is simply not to generate the derived instances at all. (A less brutal solution would be to generate them with no bindings.) This will become moot when we shift to the new TH plan, so the brutal solution will do. +-} - -\begin{code} tcLocalInstDecl :: LInstDecl Name -> TcM ([InstInfo Name], [FamInst]) -- A source-file instance declaration @@ -595,20 +594,20 @@ tcATDefault inst_subst defined_ats (ATI fam_tc defs) = (extendTvSubst subst tc_tv ty', ty') where ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Type checking family instances -%* * -%************************************************************************ +* * +************************************************************************ Family instances are somewhat of a hybrid. They are processed together with class instance heads, but can contain data constructors and hence they share a lot of kinding and type checking code with ordinary algebraic data types (and GADTs). +-} -\begin{code} tcFamInstDeclCombined :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable -> Located Name -> TcM TyCon tcFamInstDeclCombined mb_clsinfo fam_tc_lname @@ -736,8 +735,7 @@ tcDataFamInstDecl mb_clsinfo = go tvs pats go tvs pats = (reverse tvs, reverse pats) -\end{code} - +{- Note [Eta reduction for data family axioms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this @@ -766,13 +764,13 @@ See Note [Newtype eta] in TyCon. -%************************************************************************ -%* * +************************************************************************ +* * Type-checking instance declarations, pass 2 -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name] -> TcM (LHsBinds Id) -- (a) From each class declaration, @@ -795,8 +793,8 @@ tcInstDecls2 tycl_decls inst_decls -- Done ; return (dm_binds `unionBags` unionManyBags inst_binds_s) } -\end{code} +{- See Note [Default methods and instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The default method Ids are already in the type environment (see Note @@ -809,8 +807,8 @@ particular operation (see Note [INLINE and default methods] below). So right here in tcInstDecls2 we must re-extend the type envt with the default method Ids replete with their INLINE pragmas. Urk. +-} -\begin{code} tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) -- Returns a binding for the dfun tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) @@ -980,8 +978,8 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) filter isSpecInstLSig uprags -- The filter removes the pragmas for methods ; return (spec_inst_prags, mkPragFun uprags binds) } -\end{code} +{- Note [Instance method signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With -XInstanceSigs we allow the user to supply a signature for the @@ -1150,9 +1148,8 @@ Note that * We want to specialise the RHS of both $dfIxPair and $crangePair, but the SAME HsWrapper will do for both! We can call tcSpecPrag just once, and pass the result (in spec_inst_info) to tcInstanceMethods. +-} - -\begin{code} tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag tcSpecInst dfun_id prag@(SpecInstSig hs_ty) = addErrCtxt (spec_ctxt prag) $ @@ -1165,13 +1162,13 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty) spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) tcSpecInst _ _ = panic "tcSpecInst" -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Type-checking an instance method -%* * -%************************************************************************ +* * +************************************************************************ tcInstanceMethod - Make the method bindings, as a [(NonRec, HsBinds)], one per method @@ -1180,8 +1177,8 @@ tcInstanceMethod - Use sig_fn mapping instance method Name -> instance tyvars - Ditto prag_fn - Use tcValBinds to do the checking +-} -\begin{code} tcInstanceMethods :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] @@ -1223,7 +1220,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys tc_body sig_fn sel_id rn_bind bndr_loc = add_meth_ctxt sel_id rn_bind $ do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id)) - ; (meth_id, local_meth_sig, hs_wrap) + ; (meth_id, local_meth_sig, hs_wrap) <- setSrcSpan bndr_loc $ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id @@ -1274,7 +1271,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; let self_ev_bind = EvBind self_dict (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars)) - ; (meth_id, local_meth_sig, hs_wrap) + ; (meth_id, local_meth_sig, hs_wrap) <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; dm_id <- tcLookupId dm_name ; let dm_inline_prag = idInlinePragma dm_id @@ -1386,8 +1383,8 @@ warnUnsatisifiedMinimalDefinition mindef message = vcat [ptext (sLit "No explicit implementation for") ,nest 2 $ pprBooleanFormulaNice mindef ] -\end{code} +{- Note [Export helper functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We arrange to export the "helper functions" of an instance declaration, @@ -1489,13 +1486,13 @@ Note carefully: in TcSpecPrags. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Error messages} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} instDeclCtxt1 :: LHsType Name -> SDoc instDeclCtxt1 hs_inst_ty = inst_decl_ctxt (case unLoc hs_inst_ty of @@ -1539,4 +1536,3 @@ badFamInstDecl tc_name notOpenFamily :: TyCon -> SDoc notOpenFamily tc = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc) -\end{code} diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.hs index dcac9157b1..ed686da2f4 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.hs @@ -1,4 +1,3 @@ -\begin{code} {-# LANGUAGE CPP #-} module TcInteract ( @@ -49,8 +48,8 @@ import Unique( hasKey ) import FastString ( sLit ) import DynFlags import Util -\end{code} +{- ********************************************************************** * * * Main Interaction Solver * @@ -111,9 +110,8 @@ to float. This means that [w] xxx[1] ~ s [W] forall[2] . (xxx[1] ~ Empty) => Intersect (BuriedUnder sub k Empty) inv ~ Empty +-} - -\begin{code} solveFlatGivens :: CtLoc -> [EvVar] -> TcS () solveFlatGivens loc givens | null givens -- Shortcut for common case @@ -345,7 +343,7 @@ runSolverPipeline pipeline workItem , ptext (sLit "inerts =") <+> ppr final_is] ; insertInertItemTcS ct } } - where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct + where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct -> TcS (StopOrContinue Ct) run_pipeline [] res = return res run_pipeline _ (Stop ev s) = return (Stop ev s) @@ -355,8 +353,8 @@ runSolverPipeline pipeline workItem ; res <- stg ct ; traceTcS ("end stage " ++ stg_name ++ " }") empty ; run_pipeline stgs res } -\end{code} +{- Example 1: Inert: {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given) Reagent: a ~ [b] (given) @@ -379,15 +377,14 @@ Example 3: React with (a ~ Int) ==> IR (ContinueWith (F Int ~ b)) True [] React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canonicalize and get nothing +-} -\begin{code} thePipeline :: [(String,SimplifierStage)] thePipeline = [ ("canonicalization", TcCanonical.canonicalize) , ("interact with inerts", interactWithInertsStage) , ("top-level reactions", topReactionsStage) ] -\end{code} - +{- ********************************************************************************* * * The interact-with-inert Stage @@ -418,8 +415,8 @@ or, equivalently, If the work-item is Given, and the inert item is Wanted/Derived then there is no reaction +-} -\begin{code} -- Interaction result of WorkItem <~> Ct type StopNowFlag = Bool -- True <=> stop after this interaction @@ -439,9 +436,7 @@ interactWithInertsStage wi _ -> pprPanic "interactWithInerts" (ppr wi) } -- CHoleCan are put straight into inert_frozen, so never get here -- CNonCanonical have been canonicalised -\end{code} -\begin{code} data InteractResult = IRKeep | IRReplace | IRDelete instance Outputable InteractResult where ppr IRKeep = ptext (sLit "keep") @@ -475,15 +470,15 @@ solveOneFromTheOther ev_i ev_w -- But the work item *overrides* the inert item (hence IRReplace) -- See Note [Shadowing of Implicit Parameters] = return (IRReplace, True) -\end{code} +{- ********************************************************************************* * * interactIrred * * ********************************************************************************* +-} -\begin{code} -- Two pieces of irreducible evidence: if their types are *exactly identical* -- we can rewrite them. We can never improve using this: -- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not @@ -513,15 +508,15 @@ interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w }) = continueWith workItem interactIrred _ wi = pprPanic "interactIrred" (ppr wi) -\end{code} +{- ********************************************************************************* * * interactDict * * ********************************************************************************* +-} -\begin{code} interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) | Just ctev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys @@ -532,7 +527,7 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs IRReplace -> updInertDicts $ \ ds -> addDict ds cls tys workItem ; if stop_now then return (Stop ev_w (ptext (sLit "Dict equal") <+> parens (ppr inert_effect))) - else + else continueWith workItem } | cls `hasKey` ipClassNameKey @@ -587,8 +582,7 @@ addFunDepWork work_ct inert_ct derived_loc = work_loc { ctl_origin = FunDepOrigin1 work_pred work_loc inert_pred inert_loc } -\end{code} - +{- Note [Shadowing of Implicit Parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following example: @@ -644,8 +638,8 @@ I can think of two ways to fix this: interactFunEq * * ********************************************************************************* +-} -\begin{code} interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) -- Try interacting the work item with the inert set interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc @@ -672,7 +666,7 @@ interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc = do { let matching_funeqs = findFunEqsByTyCon funeqs tc ; let interact = sfInteractInert ops args (lookupFlattenTyVar eqs fsk) do_one (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = iev }) - = mapM_ (emitNewDerivedEq (ctEvLoc iev)) + = mapM_ (emitNewDerivedEq (ctEvLoc iev)) (interact iargs (lookupFlattenTyVar eqs ifsk)) do_one ct = pprPanic "interactFunEq" (ppr ct) ; mapM_ do_one matching_funeqs @@ -691,7 +685,7 @@ interactFunEq _ wi = pprPanic "interactFunEq" (ppr wi) lookupFlattenTyVar :: TyVarEnv EqualCtList -> TcTyVar -> TcType -- ^ Look up a flatten-tyvar in the inert TyVarEqs -lookupFlattenTyVar inert_eqs ftv +lookupFlattenTyVar inert_eqs ftv = case lookupVarEnv inert_eqs ftv of Just (CTyEqCan { cc_rhs = rhs } : _) -> rhs _ -> mkTyVarTy ftv @@ -712,8 +706,8 @@ reactFunEq from_this fuv1 (CtWanted { ctev_evar = evar }) fuv2 reactFunEq _ _ solve_this@(CtDerived {}) _ = pprPanic "reactFunEq" (ppr solve_this) -\end{code} +{- Note [Cache-caused loops] ~~~~~~~~~~~~~~~~~~~~~~~~~ It is very dangerous to cache a rewritten wanted family equation as 'solved' in our @@ -801,8 +795,8 @@ test when solving pairwise CFunEqCan. interactTyVarEq * * ********************************************************************************* +-} -\begin{code} interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) -- CTyEqCans are always consumed, so always returns Stop interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs , cc_ev = ev }) @@ -891,7 +885,7 @@ solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () -- say that in (a ~ xi), the type variable a does not appear in xi. -- See TcRnTypes.Ct invariants. -- --- Post: tv is unified (by side effect) with xi; +-- Post: tv is unified (by side effect) with xi; -- we often write tv := xi solveByUnification wd tv xi = do { let tv_ty = mkTyVarTy tv @@ -921,9 +915,7 @@ givenFlavour = CtGiven { ctev_pred = panic "givenFlavour:ev" ppr_kicked :: Int -> SDoc ppr_kicked 0 = empty ppr_kicked n = parens (int n <+> ptext (sLit "kicked out")) -\end{code} -\begin{code} kickOutRewritable :: CtEvidence -- Flavour of the equality that is -- being added to the inert set -> TcTyVar -- The new equality is tv ~ ty @@ -995,8 +987,8 @@ kick_out new_ev new_tv (IC { inert_eqs = tv_eqs (eq1:_) -> extendVarEnv acc_in (cc_tyvar eq1) eqs_in) where (eqs_out, eqs_in) = partition kick_out_ct eqs -\end{code} +{- Note [Kicking out inert constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given a new (a -> ty) inert, we want to kick out an existing inert @@ -1024,7 +1016,7 @@ because (~) has kind forall k. k -> k -> Constraint. So the constraint itself is ill-kinded. We can "see" k1 but not k2. That's why we use closeOverKinds to make sure we see k2. -This is not pretty. Maybe (~) should have kind +This is not pretty. Maybe (~) should have kind (~) :: forall k1 k1. k1 -> k2 -> Constraint Note [Kick out insolubles] @@ -1436,11 +1428,11 @@ then the no-superclass thing kicks in. WATCH OUT if you fiddle with InstLocOrigin! -%************************************************************************ -%* * -%* Functional dependencies, instantiation of equations -%* * -%************************************************************************ +************************************************************************ +* * +* Functional dependencies, instantiation of equations +* * +************************************************************************ When we spot an equality arising from a functional dependency, we now use that equality (a "wanted") to rewrite the work-item @@ -1457,8 +1449,8 @@ constraint right away. This avoids two dangers To achieve this required some refactoring of FunDeps.lhs (nicer now!). +-} -\begin{code} rewriteWithFunDeps :: [Equation CtLoc] -> TcS () -- NB: The returned constraints are all Derived -- Post: returns no trivial equalities (identities) and all EvVars returned are fresh @@ -1473,16 +1465,15 @@ instFunDepEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc }) where do_one subst (FDEq { fd_ty_left = ty1, fd_ty_right = ty2 }) = emitNewDerivedEq loc (Pair (Type.substTy subst ty1) (Type.substTy subst ty2)) -\end{code} - +{- ********************************************************************************* * * The top-reaction Stage * * ********************************************************************************* +-} -\begin{code} topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) topReactionsStage wi = do { inerts <- getTcSInerts @@ -1690,8 +1681,8 @@ dischargeFmv evar fmv co xi ; setEvBind evar (EvCoercion co) ; n_kicked <- kickOutRewritable givenFlavour fmv ; traceTcS "dischargeFuv" (ppr fmv <+> equals <+> ppr xi $$ ppr_kicked n_kicked) } -\end{code} +{- Note [Cached solved FunEqs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ When trying to solve, say (FunExpensive big-type ~ ty), it's important @@ -1935,8 +1926,8 @@ Conclusion, we will (correctly) end up with the unsolved goals NB: The desugarer needs be more clever to deal with equalities that participate in recursive dictionary bindings. +-} -\begin{code} data LookupInstResult = NoInstance | GenInst [CtEvidence] EvTerm @@ -2169,8 +2160,8 @@ requestCoercible loc ty1 ty2 -- Evidence for a Coercible constraint is always a coercion t1 ~R t2 where loc' = bumpCtLocDepth CountConstraints loc -\end{code} +{- Note [Coercible Instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~ The class Coercible is special: There are no regular instances, and the user @@ -2251,7 +2242,7 @@ we'd unwrap the newtype (on both sides) to get whic succeeds. So our current decision is to apply case 3 (newtype-unwrapping) first, -followed by decomposition (case 4). This is strictly more powerful +followed by decomposition (case 4). This is strictly more powerful if the newtype constructor is in scope. See Trac #9117 for a discussion. Note [Instance and Given overlap] @@ -2293,3 +2284,4 @@ overlapping checks. There we are interested in validating the following principl But for the Given Overlap check our goal is just related to completeness of constraint solving. +-} diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.hs index c7f1418fb2..d5a2781d88 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.hs @@ -1,14 +1,14 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Monadic type operations This module contains monadic operations over types that contain mutable type variables +-} -\begin{code} {-# LANGUAGE CPP #-} module TcMType ( @@ -88,16 +88,15 @@ import Bag import Control.Monad import Data.List ( partition, mapAccumL ) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Kind variables -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkKindName :: Unique -> Name mkKindName unique = mkSystemName unique kind_var_occ @@ -113,16 +112,15 @@ newMetaKindVar = do { uniq <- newUnique newMetaKindVars :: Int -> TcM [TcKind] newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ()) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Evidence variables; range over constraints we can abstract over -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} newEvVars :: TcThetaType -> TcM [EvVar] newEvVars theta = mapM newEvVar theta @@ -155,15 +153,15 @@ predTypeOccName ty = case classifyPredType ty of EqPred _ _ -> mkVarOccFS (fsLit "cobox") TuplePred _ -> mkVarOccFS (fsLit "tup") IrredPred _ -> mkVarOccFS (fsLit "irred") -\end{code} +{- ********************************************************************************* * * * Wanted constraints * * ********************************************************************************* +-} -\begin{code} newFlatWanted :: CtOrigin -> PredType -> TcM Ct newFlatWanted orig pty = do loc <- getCtLoc orig @@ -175,15 +173,15 @@ newFlatWanted orig pty newFlatWanteds :: CtOrigin -> ThetaType -> TcM [Ct] newFlatWanteds orig = mapM (newFlatWanted orig) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * SkolemTvs (immutable) -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcInstType :: ([TyVar] -> TcM (TvSubst, [TcTyVar])) -- How to instantiate the type variables -> TcType -- Type to instantiate -> TcM ([TcTyVar], TcThetaType, TcType) -- Result @@ -286,8 +284,8 @@ instSkolTyVarX mk_tv subst tyvar where old_name = tyVarName tyvar kind = substTy subst (tyVarKind tyvar) -\end{code} +{- Note [Kind substitution when instantiating] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we instantiate a bunch of kind and type variables, first we @@ -304,13 +302,13 @@ instead of the buggous [(?k1 :: BOX), (?k2 :: BOX), (?a :: k1 -> k2), (?b :: k1)] -%************************************************************************ -%* * +************************************************************************ +* * MetaTvs (meta type variables; mutable) -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar -- Make a new meta tyvar out of thin air newMetaTyVar meta_info kind @@ -440,16 +438,15 @@ writeMetaTyVarRef tyvar ref ty where tv_kind = tyVarKind tyvar ty_kind = typeKind ty -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * MetaTvs: TauTvs -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} newFlexiTyVar :: Kind -> TcM TcTyVar newFlexiTyVar kind = newMetaTyVar (TauTv False) kind @@ -484,14 +481,13 @@ tcInstTyVarX subst tyvar kind = substTy subst (tyVarKind tyvar) new_tv = mkTcTyVar name kind details ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Quantification -%* * -%************************************************************************ +* * +************************************************************************ Note [quantifyTyVars] ~~~~~~~~~~~~~~~~~~~~~ @@ -510,8 +506,8 @@ also free in the type. Eg has free vars {k,a}. But the type (see Trac #7916) (f::k->*) (a::k) has free vars {f,a}, but we must add 'k' as well! Hence step (3). +-} -\begin{code} quantifyTyVars :: TcTyVarSet -> TcTyVarSet -> TcM [TcTyVar] -- See Note [quantifyTyVars] -- The input is a mixture of type and kind variables; a kind variable k @@ -619,8 +615,8 @@ skolemiseUnboundMetaTyVar tv details generaliseWildcardVarName name | startsWithUnderscore name = mkOccNameFS (occNameSpace name) (appendFS (fsLit "w") (occNameFS name)) generaliseWildcardVarName name = name -\end{code} +{- Note [Zonking to Skolem] ~~~~~~~~~~~~~~~~~~~~~~~~ We used to zonk quantified type variables to regular TyVars. However, this @@ -687,17 +683,17 @@ Consider this: All very silly. I think its harmless to ignore the problem. We'll end up with a \/\a in the final result but all the occurrences of a will be zonked to () -%************************************************************************ -%* * +************************************************************************ +* * Zonking types -%* * -%************************************************************************ +* * +************************************************************************ @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. To improve subsequent calls to the same function it writes the zonked set back into the environment. +-} -\begin{code} tcGetGlobalTyVars :: TcM TcTyVarSet tcGetGlobalTyVars = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv @@ -706,9 +702,7 @@ tcGetGlobalTyVars ; writeMutVar gtv_var gbl_tvs' ; return gbl_tvs' } where -\end{code} -\begin{code} zonkTcTypeAndFV :: TcType -> TcM TyVarSet -- Zonk a type and take its free variables -- With kind polymorphism it can be essential to zonk *first* @@ -746,15 +740,15 @@ zonkTcThetaType theta = mapM zonkTcPredType theta zonkTcPredType :: TcPredType -> TcM TcPredType zonkTcPredType = zonkTcType -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Zonking constraints -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} zonkImplication :: Implication -> TcM (Bag Implication) zonkImplication implic@(Implic { ic_skols = skols , ic_given = given @@ -787,9 +781,7 @@ zonkWCRec (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) ; implic' <- flatMapBagM zonkImplication implic ; insol' <- zonkFlats insol ; return (WC { wc_flat = flat', wc_impl = implic', wc_insol = insol' }) } -\end{code} -\begin{code} zonkFlats :: Cts -> TcM Cts zonkFlats cts = do { cts' <- mapBagM zonkCt' cts ; traceTc "zonkFlats done:" (ppr cts') @@ -825,19 +817,17 @@ zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys where do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } zonkSkolemInfo skol_info = return skol_info -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} -%* * -%* For internal use only! * -%* * -%************************************************************************ +* * +* For internal use only! * +* * +************************************************************************ +-} -\begin{code} -- zonkId is used *during* typechecking just to zonk the Id's type zonkId :: TcId -> TcM TcId zonkId id @@ -908,30 +898,26 @@ zonkTcTyVar tv where zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv ; return (TyVarTy z_tv) } -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * Zonking kinds -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} zonkTcKind :: TcKind -> TcM TcKind zonkTcKind k = zonkTcType k -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * Tidying -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) zonkTidyTcType env ty = do { ty' <- zonkTcType ty ; return (tidyOpenType env ty') } @@ -1008,15 +994,14 @@ tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) ty' = tidyType env2 ty tidySkolemInfo env info = (env, info) -\end{code} -%************************************************************************ -%* * - (Named) Wildcards -%* * -%************************************************************************ - -\begin{code} +{- +************************************************************************ +* * + (Named) Wildcards +* * +************************************************************************ +-} -- | Create a new meta var with the given kind. This meta var should be used -- to replace a wildcard in a type. Such a wildcard meta var can be @@ -1037,4 +1022,3 @@ newWildcardVarMetaKind name = do kind <- newMetaKindVar isWildcardVar :: TcTyVar -> Bool isWildcardVar tv | isTcTyVar tv, MetaTv (TauTv True) _ _ <- tcTyVarDetails tv = True isWildcardVar _ = False -\end{code} diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.hs index b4e31801ee..dda97d19ed 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + TcMatches: Typecheck some @Matches@ +-} -\begin{code} {-# LANGUAGE CPP, RankNTypes #-} module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, @@ -43,13 +43,13 @@ import MkCore import Control.Monad #include "HsVersions.h" -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{tcMatchesFun, tcMatchesCase} -%* * -%************************************************************************ +* * +************************************************************************ @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a @FunMonoBind@. The second argument is the name of the function, which @@ -61,8 +61,8 @@ Note [Polymorphic expected type for tcMatchesFun] tcMatchesFun may be given a *sigma* (polymorphic) type so it must be prepared to use tcGen to skolemise it. See Note [sig_tau may be polymorphic] in TcPat. +-} -\begin{code} tcMatchesFun :: Name -> Bool -> MatchGroup Name (LHsExpr Name) -> TcSigmaType -- Expected type of function @@ -89,12 +89,12 @@ tcMatchesFun fun_name inf matches exp_ty herald = ptext (sLit "The equation(s) for") <+> quotes (ppr fun_name) <+> ptext (sLit "have") match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody } -\end{code} +{- @tcMatchesCase@ doesn't do the argument-count check because the parser guarantees that each equation has exactly one argument. +-} -\begin{code} tcMatchesCase :: (Outputable (body Name)) => TcMatchCtxt body -- Case context -> TcRhoType -- Type of scrutinee @@ -123,11 +123,9 @@ tcMatchLambda match res_ty ptext (sLit "has")] match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } -\end{code} -@tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. +-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. -\begin{code} tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType -> TcM (GRHSs TcId (LHsExpr TcId)) -- Used for pattern bindings @@ -135,10 +133,7 @@ tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty where match_ctxt = MC { mc_what = PatBindRhs, mc_body = tcBody } -\end{code} - -\begin{code} matchFunTys :: SDoc -- See Note [Herald for matchExpecteFunTys] in TcUnify -> Arity @@ -153,15 +148,15 @@ matchFunTys herald arity res_ty thing_inside = do { (co, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty ; res <- thing_inside pat_tys res_ty ; return (coToHsWrapper (mkTcSymCo co), res) } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{tcMatch} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcMatches :: (Outputable (body Name)) => TcMatchCtxt body -> [TcSigmaType] -- Expected pattern types -> TcRhoType -- Expected result-type of the Match. @@ -236,16 +231,15 @@ tcGRHS ctxt res_ty (GRHS guards rhs) ; return (GRHS guards' rhs') } where stmt_ctxt = PatGuard (mc_what ctxt) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{@tcDoStmts@ typechecks a {\em list} of do statements} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcDoStmts :: HsStmtContext Name -> [LStmt Name (LHsExpr Name)] -> TcRhoType @@ -282,16 +276,14 @@ tcBody body res_ty ; body' <- tcMonoExpr body res_ty ; return body' } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{tcStmts} -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} type TcExprStmtChecker = TcStmtChecker HsExpr type TcCmdStmtChecker = TcStmtChecker HsCmd @@ -826,8 +818,8 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names tcDoStmt _ stmt _ _ = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) -\end{code} +{- Note [Treat rebindable syntax first] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When typechecking @@ -839,16 +831,16 @@ Otherwise the error shows up when cheking the rebindable syntax, and the expected/inferred stuff is back to front (see Trac #3613). -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Errors and contexts} -%* * -%************************************************************************ +* * +************************************************************************ @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same number of args are used in each equation. +-} -\begin{code} checkArgs :: Name -> MatchGroup Name body -> TcM () checkArgs _ (MG { mg_alts = [] }) = return () @@ -866,5 +858,3 @@ checkArgs fun (MG { mg_alts = match1:matches }) args_in_match :: LMatch Name body -> Int args_in_match (L _ (Match pats _ _)) = length pats -\end{code} - diff --git a/compiler/typecheck/TcMatches.lhs-boot b/compiler/typecheck/TcMatches.hs-boot index 1fe05ec1e5..50bad30aa7 100644 --- a/compiler/typecheck/TcMatches.lhs-boot +++ b/compiler/typecheck/TcMatches.hs-boot @@ -1,4 +1,3 @@ -\begin{code} module TcMatches where import HsSyn ( GRHSs, MatchGroup, LHsExpr ) import TcEvidence( HsWrapper ) @@ -15,4 +14,3 @@ tcMatchesFun :: Name -> Bool -> MatchGroup Name (LHsExpr Name) -> TcRhoType -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) -\end{code} diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.hs index 58e8bae8fc..a8889b545f 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + TcPat: Typechecking patterns +-} -\begin{code} {-# LANGUAGE CPP, RankNTypes #-} module TcPat ( tcLetPat, TcSigFun, TcPragFun @@ -48,16 +48,15 @@ import Util import Outputable import FastString import Control.Monad -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * External interface -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcLetPat :: TcSigFun -> LetBndrSpec -> LPat Name -> TcSigmaType -> TcM a @@ -211,8 +210,8 @@ instance Outputable TcPatSynInfo where isPartialSig :: TcSigInfo -> Bool isPartialSig = sig_partial -\end{code} +{- Note [Binding scoped type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The type variables *brought into lexical scope* by a type signature may @@ -265,13 +264,13 @@ bound by C don't unify with the free variables of pat_ty, OR res_ty res_ty free vars. -%************************************************************************ -%* * +************************************************************************ +* * Binders -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (TcCoercion, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) @@ -336,8 +335,8 @@ warnPrags id bad_sigs herald mkLocalBinder :: Name -> TcType -> TcM TcId mkLocalBinder name ty = return (Id.mkLocalId name ty) -\end{code} +{- Note [Typing patterns in pattern bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we are typing a pattern binding @@ -367,11 +366,11 @@ Two cases, dealt with by the LetPat case of tcPatBndr context type. -%************************************************************************ -%* * +************************************************************************ +* * The main worker functions -%* * -%************************************************************************ +* * +************************************************************************ Note [Nesting] ~~~~~~~~~~~~~~ @@ -383,8 +382,8 @@ pattern. This does not work so well for the ErrCtxt carried by the monad: we don't want the error-context for the pattern to scope over the RHS. Hence the getErrCtxt/setErrCtxt stuff in tcMultiple +-} -\begin{code} -------------------- type Checker inp out = forall r. inp @@ -634,8 +633,8 @@ unifyPatType :: TcType -> TcType -> TcM TcCoercion unifyPatType actual_ty expected_ty = do { coi <- unifyType actual_ty expected_ty ; return (mkTcSymCo coi) } -\end{code} +{- Note [Hopping the LIE in lazy patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a lazy pattern, we must *not* discharge constraints from the RHS @@ -659,12 +658,12 @@ Finally, a lazy pattern should not bind any existential type variables because they won't be in scope when we do the desugaring -%************************************************************************ -%* * +************************************************************************ +* * Most of the work for constructors is here (the rest is in the ConPatIn case of tc_pat) -%* * -%************************************************************************ +* * +************************************************************************ [Pattern matching indexed data types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -718,8 +717,8 @@ between alternatives. RIP GADT refinement: refinements have been replaced by the use of explicit equality constraints that are used in conjunction with implication constraints to express the local scope of GADT refinements. +-} -\begin{code} -- Running example: -- MkT :: forall a b c. (a~[b]) => b -> c -> T a -- with scrutinee of type (T ty) @@ -917,8 +916,8 @@ matchExpectedConTy data_tc pat_ty | otherwise = matchExpectedTyConApp data_tc pat_ty -- coi : T tys ~ pat_ty -\end{code} +{- Note [Matching constructor patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (coi, tys) = matchExpectedConType data_tc pat_ty @@ -945,8 +944,8 @@ Suppose (coi, tys) = matchExpectedConType data_tc pat_ty For families we do all this matching here, not in the unifier, because we never want a whisper of the data_tycon to appear in error messages; it's a purely internal thing +-} -\begin{code} tcConArgs :: ConLike -> [TcSigmaType] -> Checker (HsConPatDetails Name) (HsConPatDetails Id) @@ -1015,9 +1014,7 @@ conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn tcConArg :: Checker (LPat Name, TcSigmaType) (LPat Id) tcConArg (arg_pat, arg_ty) penv thing_inside = tc_lpat arg_pat arg_ty penv thing_inside -\end{code} -\begin{code} addDataConStupidTheta :: DataCon -> [TcType] -> TcM () -- Instantiate the "stupid theta" of the data con, and throw -- the constraints into the constraint set @@ -1033,8 +1030,8 @@ addDataConStupidTheta data_con inst_tys -- NB: inst_tys can be longer than the univ tyvars -- because the constructor might have existentials inst_theta = substTheta tenv stupid_theta -\end{code} +{- Note [Arrows and patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~ (Oct 07) Arrow noation has the odd property that it involves @@ -1059,11 +1056,11 @@ constraints. Hence the 'fast path' in tcConPat; but it's also a good plan for ordinary vanilla patterns to bypass the constraint simplification step. -%************************************************************************ -%* * +************************************************************************ +* * Note [Pattern coercions] -%* * -%************************************************************************ +* * +************************************************************************ In principle, these program would be reasonable: @@ -1120,13 +1117,13 @@ Meanwhile, the strategy is: the result to bind the new variable (gi, gb, etc) -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Errors and contexts} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b -- Not all patterns are worth pushing a context maybeWrapPatCtxt pat tcm thing_inside @@ -1179,4 +1176,3 @@ lazyUnliftedPatErr pat = failWithTc $ hang (ptext (sLit "A lazy (~) pattern cannot contain unlifted types:")) 2 (ppr pat) -\end{code} diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.hs index 16824dee6a..9cc49111ac 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + \section[TcPatSyn]{Typechecking pattern synonym declarations} +-} -\begin{code} {-# LANGUAGE CPP #-} module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl @@ -46,15 +46,15 @@ import Data.Maybe import Control.Monad (forM) #include "HsVersions.h" -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Type checking a pattern synonym -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcInferPatSynDecl :: PatSynBind Name Name -> TcM (PatSyn, LHsBinds Id) tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, @@ -211,16 +211,15 @@ tc_patsyn_finish lname dir is_infix lpat' qtvs = univ_tvs ++ ex_tvs theta = prov_theta ++ req_theta arg_tys = map (varType . fst) wrapped_args -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Constructing the "matcher" Id and its binding -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcPatSynMatcher :: Located Name -> LPat Id -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) @@ -309,16 +308,15 @@ isUnidirectional :: HsPatSynDir a -> Bool isUnidirectional Unidirectional = True isUnidirectional ImplicitBidirectional = False isUnidirectional ExplicitBidirectional{} = False -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Constructing the "builder" Id -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkPatSynBuilderId :: HsPatSynDir a -> Located Name -> [TyVar] -> ThetaType -> [Type] -> Type -> TcM (Maybe (Id, Bool)) @@ -413,14 +411,13 @@ tcPatSynBuilderOcc orig ps where name = patSynName ps builder = patSynBuilder ps -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Helper functions -%* * -%************************************************************************ +* * +************************************************************************ Note [As-patterns in pattern synonym definitions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -437,8 +434,8 @@ one could write a nonsensical function like or g (K (Just True) False) = ... +-} -\begin{code} tcCheckPatSynPat :: LPat Name -> TcM () tcCheckPatSynPat = go where @@ -563,5 +560,3 @@ tcCollectEx = return . go goRecFd :: LHsRecField Id (LPat Id) -> (TyVarSet, [EvVar]) goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p - -\end{code} diff --git a/compiler/typecheck/TcPatSyn.lhs-boot b/compiler/typecheck/TcPatSyn.hs-boot index 697f377a95..102404a0ca 100644 --- a/compiler/typecheck/TcPatSyn.lhs-boot +++ b/compiler/typecheck/TcPatSyn.hs-boot @@ -1,4 +1,3 @@ -\begin{code} module TcPatSyn where import Name ( Name ) @@ -17,4 +16,3 @@ tcCheckPatSynDecl :: PatSynBind Name Name tcPatSynBuilderBind :: PatSynBind Name Name -> TcM (LHsBinds Id) -\end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.hs index 29086c6ebe..6a52de9cae 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + \section[TcMovectle]{Typechecking a whole module} +-} -\begin{code} {-# LANGUAGE CPP, NondecreasingIndentation #-} module TcRnDriver ( @@ -105,16 +105,15 @@ import Bag import Control.Monad #include "HsVersions.h" -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Typecheck and rename a module -%* * -%************************************************************************ - +* * +************************************************************************ +-} -\begin{code} -- | Top level entry point for typechecker and renamer tcRnModule :: HscEnv -> HscSource @@ -289,7 +288,7 @@ tcRnModuleTcRnM hsc_env hsc_src tcg_env <- {-# SCC "tcRnImports" #-} tcRnImports hsc_env (prel_imports ++ import_decls) ; - -- If the whole module is warned about or deprecated + -- If the whole module is warned about or deprecated -- (via mod_deprec) record that in tcg_warns. If we do thereby add -- a WarnAll, it will override any subseqent depracations added to tcg_warns let { tcg_env1 = case mod_deprec of @@ -375,16 +374,15 @@ tcRnModuleTcRnM hsc_env hsc_src implicitPreludeWarn :: SDoc implicitPreludeWarn = ptext (sLit "Module `Prelude' implicitly imported") -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Import declarations -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv tcRnImports hsc_env import_decls = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; @@ -448,16 +446,15 @@ tcRnImports hsc_env import_decls ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; ; getGblEnv } } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Type-checking the top level of a module -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcRnSrcDecls :: ModDetails -> Bag OccName -> [LHsDecl RdrName] -> TcM TcGblEnv -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings @@ -517,7 +514,7 @@ tcRnSrcDecls boot_iface exports decls tcg_fords = fords' } } ; setGlobalTypeEnv tcg_env' final_type_env - + } } tc_rn_src_decls :: ModDetails @@ -554,7 +551,7 @@ tc_rn_src_decls boot_details ds -> setSrcSpan loc $ addErr (ptext (sLit "Declaration splices are not permitted inside top-level declarations added with addTopDecls")) } ; - + -- Rename TH-generated top-level declarations ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $ rnTopSrcDecls extra_deps th_group @@ -604,16 +601,16 @@ tc_rn_src_decls boot_details ds } #endif /* GHCI */ } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Compiling hs-boot source files, and comparing the hi-boot interface with the real thing -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv tcRnHsBootDecls hsc_src decls = do { (first_group, group_tail) <- findSplice decls @@ -683,12 +680,12 @@ badBootDecl hsc_src what (L loc _) HsigFile -> ptext (sLit "hsig") _ -> panic "badBootDecl: should be an hsig or hs-boot file") <+> ptext (sLit "file")) -\end{code} +{- Once we've typechecked the body of the module, we want to compare what we've found (gathered in a TypeEnv) with the hi-boot details (if any). +-} -\begin{code} checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv -- Compare the hi-boot file for this module (if there is one) -- with the type environment we've just come up with @@ -861,7 +858,7 @@ checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc checkListBy check_fun as bs whats = go [] as bs where herald = text "The" <+> whats <+> text "do not match" - + go [] [] [] = Nothing go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs)) go docs (x:xs) (y:ys) = case check_fun x y of @@ -922,7 +919,7 @@ checkBootTyCon tc1 tc2 -- Ignore the location of the defaults eqATDef Nothing Nothing = True eqATDef (Just ty1) (Just ty2) = eqTypeX env ty1 ty2 - eqATDef _ _ = False + eqATDef _ _ = False eqFD (as1,bs1) (as2,bs2) = eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && @@ -1057,14 +1054,13 @@ instMisMatch is_boot inst 2 (ptext (sLit "is defined in the") <+> (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig")) <+> ptext (sLit "file, but not in the module itself")) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Type-checking the top level of a module -%* * -%************************************************************************ +* * +************************************************************************ tcRnGroup takes a bunch of top-level source-code declarations, and * renames them @@ -1076,8 +1072,8 @@ tcRnGroup takes a bunch of top-level source-code declarations, and In Template Haskell it may be called repeatedly for each group of declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. +-} -\begin{code} ------------------------------------------------ rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) -- Fails if there are any errors @@ -1099,17 +1095,15 @@ rnTopSrcDecls extra_deps group return (tcg_env', rn_decls) } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * tcTopSrcDecls -%* * -%************************************************************************ +* * +************************************************************************ +-} - -\begin{code} tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) tcTopSrcDecls boot_details (HsGroup { hs_tyclds = tycl_decls, @@ -1181,7 +1175,7 @@ tcTopSrcDecls boot_details foe_binds ; fo_gres = fi_gres `unionBags` foe_gres - ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre) + ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre) emptyFVs fo_gres ; fo_rdr_names :: [RdrName] ; fo_rdr_names = foldrBag gre_to_rdr_name [] fo_gres @@ -1219,8 +1213,8 @@ tcTopSrcDecls boot_details occName = nameOccName (gre_name gre) --------------------------- -tcTyClsInstDecls :: ModDetails - -> [TyClGroup Name] +tcTyClsInstDecls :: ModDetails + -> [TyClGroup Name] -> [LInstDecl Name] -> [LDerivDecl Name] -> TcM (TcGblEnv, -- The full inst env @@ -1229,7 +1223,7 @@ tcTyClsInstDecls :: ModDetails HsValBinds Name) -- Supporting bindings for derived instances tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls - = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE) + = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE) | lid <- inst_decls, con <- get_cons lid ] $ -- Note [AFamDataCon: not promoting data family constructors] do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; @@ -1246,8 +1240,8 @@ tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls get_fi_cons :: DataFamInstDecl Name -> [Name] get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } }) = map unLoc $ concatMap (con_names . unLoc) cons -\end{code} +{- Note [AFamDataCon: not promoting data family constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1267,13 +1261,13 @@ constructors, bound to AFamDataCon, so that if we trip over 'MkT' when type checking 'S' we'll produce a decent error message. -%************************************************************************ -%* * +************************************************************************ +* * Checking for 'main' -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} checkMain :: TcM TcGblEnv -- If we are in module Main, check that 'main' is defined. checkMain @@ -1355,7 +1349,7 @@ checkMainExported :: TcGblEnv -> TcM () checkMainExported tcg_env = case tcg_main tcg_env of Nothing -> return () -- not the main module - Just main_name -> + Just main_name -> do { dflags <- getDynFlags ; let main_mod = mainModIs dflags ; checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $ @@ -1371,9 +1365,8 @@ ppMainFn main_fn mainOcc :: OccName mainOcc = mkVarOccFS (fsLit "main") -\end{code} - +{- Note [Root-main Id] ~~~~~~~~~~~~~~~~~~~ The function that the RTS invokes is always :Main.main, which we call @@ -1387,13 +1380,13 @@ module. Tiresomely, we must filter it out again in MkIface, les we get two defns for 'main' in the interface file! -%********************************************************* -%* * +********************************************************* +* * GHCi stuff -%* * -%********************************************************* +* * +********************************************************* +-} -\begin{code} runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports @@ -1512,9 +1505,8 @@ tcRnStmt hsc_env rdr_stmt where bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) -\end{code} - +{- -------------------------------------------------------------------------- Typechecking Stmts in GHCi @@ -1536,8 +1528,7 @@ Here is the grand plan, implemented in tcUserStmt expr (of non-IO type, result not showable) ==> error - -\begin{code} +-} -- | A plan is an attempt to lift some code into the IO monad. type PlanResult = ([Id], LHsExpr Id) @@ -1636,7 +1627,7 @@ tcUserStmt rdr_stmt@(L loc _) ; opt_pr_flag <- goptM Opt_PrintBindResult ; let print_result_plan - | opt_pr_flag -- The flag says "print result" + | opt_pr_flag -- The flag says "print result" , [v] <- collectLStmtBinders gi_stmt -- One binder = [mk_print_result_plan gi_stmt v] | otherwise = [] @@ -1731,7 +1722,7 @@ isGHCiMonad hsc_env ty case occIO of Just [n] -> do let name = gre_name n - ghciClass <- tcLookupClass ghciIoClassName + ghciClass <- tcLookupClass ghciIoClassName userTyCon <- tcLookupTyCon name let userTy = mkTyConApp userTyCon [] _ <- tcLookupInstance ghciClass [userTy] @@ -1740,11 +1731,8 @@ isGHCiMonad hsc_env ty Just _ -> failWithTc $ text "Ambigous type!" Nothing -> failWithTc $ text ("Can't find type:" ++ ty) -\end{code} - -tcRnExpr just finds the type of an expression +-- tcRnExpr just finds the type of an expression -\begin{code} tcRnExpr :: HscEnv -> LHsExpr RdrName -> IO (Messages, Maybe Type) @@ -1787,11 +1775,9 @@ tcRnImportDecls hsc_env import_decls ; return (tcg_rdr_env gbl_env) } where zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } -\end{code} -tcRnType just finds the kind of a type +-- tcRnType just finds the kind of a type -\begin{code} tcRnType :: HscEnv -> Bool -- Normalise the returned type -> LHsType RdrName @@ -1814,8 +1800,8 @@ tcRnType hsc_env normalise rdr_type else return ty ; ; return (ty', typeKind ty) } -\end{code} +{- Note [Kind-generalise in tcRnType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We switch on PolyKinds when kind-checking a user type, so that we will @@ -1827,15 +1813,15 @@ kind-polymorphic you won't get anything unexpected, but the apparent quite surprising. See Trac #7688 for a discussion. -%************************************************************************ -%* * +************************************************************************ +* * tcRnDeclsi -%* * -%************************************************************************ +* * +************************************************************************ tcRnDeclsi exists to allow class, data, and other declarations in GHCi. +-} -\begin{code} tcRnDeclsi :: HscEnv -> [LHsDecl RdrName] -> IO (Messages, Maybe TcGblEnv) @@ -1873,18 +1859,17 @@ tcRnDeclsi hsc_env local_decls = tcg_fords = fords' } setGlobalTypeEnv tcg_env' final_type_env - -#endif /* GHCi */ -\end{code} +#endif /* GHCi */ -%************************************************************************ -%* * +{- +************************************************************************ +* * More GHCi stuff, to do with browsing and getting info -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} #ifdef GHCI -- | ASSUMES that the module is either in the 'HomePackageTable' or is -- a package module with an interface on disk. If neither of these is @@ -2017,15 +2002,15 @@ loadUnqualIfaces hsc_env ictxt , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre ] -- In scope unqualified doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Degugging output -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} rnDump :: SDoc -> TcRn () -- Dump, with a banner, if -ddump-rn rnDump doc = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) } @@ -2123,17 +2108,15 @@ ppr_tydecls tycons = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons)) where ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ] -\end{code} - +{- ******************************************************************************** Type Checker Plugins ******************************************************************************** +-} - -\begin{code} withTcPlugins :: HscEnv -> TcM a -> TcM a withTcPlugins hsc_env m = do plugins <- liftIO (loadTcPlugins hsc_env) @@ -2158,4 +2141,3 @@ loadTcPlugins hsc_env = where load_plugin (_, plug, opts) = tcPlugin plug opts #endif -\end{code} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.hs index c27ce9822b..2672067cbc 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow 2006 -% +{- +(c) The University of Glasgow 2006 + Functions for working with the typechecker environment (setters, getters...). +-} -\begin{code} {-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -60,17 +60,14 @@ import Control.Monad #ifdef GHCI import qualified Data.Map as Map #endif -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * initTc -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} -- | Setup the initial typechecking environment initTc :: HscEnv @@ -223,16 +220,15 @@ initTcForLookup hsc_env thing_inside case m of Nothing -> throwIO $ mkSrcErr $ snd msgs Just x -> return x -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Initialisation -%* * -%************************************************************************ +* * +************************************************************************ +-} - -\begin{code} initTcRnIf :: Char -- Tag for unique supply -> HscEnv -> gbl -> lcl @@ -249,15 +245,15 @@ initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside ; runIOEnv env thing_inside } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Simple accessors -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} discardResult :: TcM a -> TcM () discardResult a = a >> return () @@ -289,12 +285,9 @@ getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) -\end{code} - -Command-line flags +-- Command-line flags -\begin{code} xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } @@ -338,18 +331,14 @@ whenXOptM flag thing_inside = do b <- xoptM flag getGhcMode :: TcRnIf gbl lcl GhcMode getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } -\end{code} -\begin{code} withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a withDoDynamicToo m = do env <- getEnv let dflags = extractDynFlags env dflags' = dynamicTooMkDynamicDynFlags dflags env' = replaceDynFlags env dflags' setEnv env' m -\end{code} -\begin{code} getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } @@ -385,15 +374,15 @@ getHpt = do { env <- getTopEnv; return (hsc_HPT env) } getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) ; return (eps, hsc_HPT env) } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Unique supply -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} newUnique :: TcRnIf gbl lcl Unique newUnique = do { env <- getEnv ; @@ -445,16 +434,15 @@ newSysLocalIds fs tys instance MonadUnique (IOEnv (Env gbl lcl)) where getUniqueM = newUnique getUniqueSupplyM = newUniqueSupply -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Debugging -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} newTcRef :: a -> TcRnIf gbl lcl (TcRef a) newTcRef = newMutVar @@ -466,15 +454,15 @@ writeTcRef = writeMutVar updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () updTcRef = updMutVar -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Debugging -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} traceTc :: String -> SDoc -> TcRn () traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc) @@ -539,13 +527,13 @@ printForUserTcRn doc debugDumpTcRn :: SDoc -> TcRn () debugDumpTcRn doc = unless opt_NoDebugOutput $ traceOptTcRn Opt_D_dump_tc doc -\end{code} +{- traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is available. Alas, they behave inconsistently with the other stuff; e.g. are unaffected by -dump-to-file. +-} -\begin{code} traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () traceIf = traceOptIf Opt_D_dump_if_trace traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs @@ -556,15 +544,15 @@ traceOptIf flag doc = whenDOptM flag $ -- No RdrEnv available, so qualify everything do { dflags <- getDynFlags ; liftIO (putMsg dflags doc) } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Typechecker global environment -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} setModule :: Module -> TcRn a -> TcRn a setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside @@ -609,15 +597,15 @@ addDependentFiles fs = do ref <- fmap tcg_dependent_files getGblEnv dep_files <- readTcRef ref writeTcRef ref (fs ++ dep_files) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Error management -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) } @@ -645,11 +633,9 @@ wrapLocSndM fn (L loc a) = setSrcSpan loc $ do (b,c) <- fn a return (b, L loc c) -\end{code} -Reporting errors +-- Reporting errors -\begin{code} getErrsVar :: TcRn (TcRef Messages) getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } @@ -702,19 +688,18 @@ discardWarnings thing_inside -- Revert warnings to old_warns ; (_new_warns, new_errs) <- readTcRef errs_var - ; writeTcRef errs_var (old_warns, new_errs) + ; writeTcRef errs_var (old_warns, new_errs) ; return result } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Shared error message stuff: renamer and typechecker -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg mkLongErrAt loc msg extra = do { dflags <- getDynFlags ; @@ -740,10 +725,7 @@ reportWarning warn errs_var <- getErrsVar ; (warns, errs) <- readTcRef errs_var ; writeTcRef errs_var (warns `snocBag` warn, errs) } -\end{code} - -\begin{code} try_m :: TcRn r -> TcRn (Either IOEnvFailure r) -- Does try_m, with a debug-trace on failure try_m thing @@ -891,16 +873,15 @@ failTH e what -- Raise an error in a stage-1 compiler <+> ptext (sLit "requires GHC with interpreter support:")) 2 (ppr e) , ptext (sLit "Perhaps you are using a stage-1 compiler?") ]) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Context management for the type checker -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} getErrCtxt :: TcM [ErrCtxt] getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } @@ -926,7 +907,7 @@ popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) getCtLoc :: CtOrigin -> TcM CtLoc getCtLoc origin - = do { env <- getLclEnv + = do { env <- getLclEnv ; return (CtLoc { ctl_origin = origin , ctl_env = env , ctl_depth = initialSubGoalDepth }) } @@ -936,21 +917,21 @@ setCtLoc :: CtLoc -> TcM a -> TcM a setCtLoc (CtLoc { ctl_env = lcl }) thing_inside = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl , tcl_bndrs = tcl_bndrs lcl - , tcl_ctxt = tcl_ctxt lcl }) + , tcl_ctxt = tcl_ctxt lcl }) thing_inside -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Error message generation (type checker) -%* * -%************************************************************************ +* * +************************************************************************ The addErrTc functions add an error message, but do not cause failure. The 'M' variants pass a TidyEnv that has already been used to tidy up the message; we then use it to tidy the context messages +-} -\begin{code} addErrTc :: MsgDoc -> TcM () addErrTc err_msg = do { env0 <- tcInitTidyEnv ; addErrTcM (env0, err_msg) } @@ -971,11 +952,9 @@ mkErrTcM (tidy_env, err_msg) loc <- getSrcSpanM ; err_info <- mkErrInfo tidy_env ctxt ; mkLongErrAt loc err_msg err_info } -\end{code} -The failWith functions add an error message and cause failure +-- The failWith functions add an error message and cause failure -\begin{code} failWithTc :: MsgDoc -> TcM a -- Add an error message and fail failWithTc err_msg = addErrTc err_msg >> failM @@ -987,11 +966,9 @@ failWithTcM local_and_msg checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true checkTc True _ = return () checkTc False err = failWithTc err -\end{code} - Warnings have no 'M' variant, nor failure +-- Warnings have no 'M' variant, nor failure -\begin{code} warnTc :: Bool -> MsgDoc -> TcM () warnTc warn_if_true warn_msg | warn_if_true = addWarnTc warn_msg @@ -1014,7 +991,7 @@ addWarnAt :: SrcSpan -> MsgDoc -> TcRn () addWarnAt loc msg = add_warn_at loc msg Outputable.empty add_warn :: MsgDoc -> MsgDoc -> TcRn () -add_warn msg extra_info +add_warn msg extra_info = do { loc <- getSrcSpanM ; add_warn_at loc msg extra_info } @@ -1030,12 +1007,12 @@ tcInitTidyEnv :: TcM TidyEnv tcInitTidyEnv = do { lcl_env <- getLclEnv ; return (tcl_tidy lcl_env) } -\end{code} +{- ----------------------------------- Other helper functions +-} -\begin{code} add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan -> [ErrCtxt] -> TcM () @@ -1064,24 +1041,22 @@ mkErrInfo env ctxts mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts mAX_CONTEXTS = 3 -\end{code} -debugTc is useful for monadic debugging code +-- debugTc is useful for monadic debugging code -\begin{code} debugTc :: TcM () -> TcM () debugTc thing | debugIsOn = thing | otherwise = return () -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Type constraints -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} newTcEvBinds :: TcM EvBindsVar newTcEvBinds = do { ref <- newTcRef emptyEvBindMap ; uniq <- newUnique @@ -1129,7 +1104,7 @@ emitFlats :: Cts -> TcM () emitFlats cts = do { lie_var <- getConstraintVar ; updTcRef lie_var (`addFlats` cts) } - + emitImplication :: Implication -> TcM () emitImplication ct = do { lie_var <- getConstraintVar ; @@ -1176,7 +1151,7 @@ getTcLevel = do { env <- getLclEnv ; return (tcl_tclvl env) } setTcLevel :: TcLevel -> TcM a -> TcM a -setTcLevel tclvl thing_inside +setTcLevel tclvl thing_inside = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside isTouchableTcM :: TcTyVar -> TcM Bool @@ -1214,16 +1189,15 @@ emitWildcardHoleConstraints wcs , cc_occ = occName name , cc_hole = TypeHole } ; emitInsoluble can } } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Template Haskell context -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} recordThUse :: TcM () recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } @@ -1248,16 +1222,15 @@ getStageAndBindLevel name setStage :: ThStage -> TcM a -> TcRn a setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Safe Haskell context -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Mark that safe inference has failed recordUnsafeInfer :: TcM () recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False @@ -1270,32 +1243,30 @@ finalSafeMode dflags tcg_env = do Sf_None | safeInferOn dflags && safeInf -> Sf_Safe | otherwise -> Sf_None s -> s -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Stuff for the renamer's local env -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} getLocalRdrEnv :: RnM LocalRdrEnv getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a setLocalRdrEnv rdr_env thing_inside = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Stuff for interface decls -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkIfLclEnv :: Module -> SDoc -> IfLclEnv mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, if_loc = loc, @@ -1406,8 +1377,8 @@ forkM doc thing_inside Nothing -> pgmError "Cannot continue after interface file error" -- pprPanic "forkM" doc Just r -> r) } -\end{code} +{- Note [Masking exceptions in forkM_maybe] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1422,4 +1393,5 @@ unsafeInterleaveIO. If that is the case, the exception handler will rethrow the asynchronous exception as a synchronous exception, and the exception will end up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed discussion). We don't currently know a general solution to this problem, but -we can use uninterruptibleMask_ to avoid the situation. +we can use uninterruptibleMask_ to avoid the situation. +-} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.hs index 96006fbeb2..9bc793a831 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.hs @@ -1,7 +1,7 @@ +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-2002 -% (c) The University of Glasgow 2006-2012 -% (c) The GRASP Project, Glasgow University, 1992-2002 -% Various types used during typechecking, please see TcRnMonad as well for operations on these types. You probably want to import it, instead of this @@ -14,8 +14,8 @@ like fashion when entering expressions... ect. For state that is global and should be returned at the end (e.g not part of the stack mechanism), you should use an TcRef (= IORef) to store them. +-} -\begin{code} {-# LANGUAGE CPP, ExistentialQuantification #-} module TcRnTypes( @@ -79,7 +79,7 @@ module TcRnTypes( TcPluginM, runTcPluginM, unsafeTcPluginTcM, -- Pretty printing - pprEvVarTheta, + pprEvVarTheta, pprEvVars, pprEvVarWithType, pprArising, pprArisingAt, @@ -135,19 +135,18 @@ import Data.Typeable ( TypeRep ) import qualified Language.Haskell.TH as TH #endif -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Standard monad definition for TcRn All the combinators for the monad can be found in TcRnMonad -%* * -%************************************************************************ +* * +************************************************************************ The monad itself has to be defined here, because it is mentioned by ErrCtxt +-} -\begin{code} -- | Type alias for 'IORef'; the convention is we'll use this for mutable -- bits of data in 'TcGblEnv' which are updated during typechecking and -- returned at the end. @@ -175,28 +174,27 @@ type RnM = TcRn -- | Historical "type-checking monad" (now it's just 'TcRn'). type TcM = TcRn -\end{code} +{- Representation of type bindings to uninstantiated meta variables used during constraint solving. +-} -\begin{code} data TcTyVarBind = TcTyVarBind TcTyVar TcType type TcTyVarBinds = Bag TcTyVarBind instance Outputable TcTyVarBind where ppr (TcTyVarBind tv ty) = ppr tv <+> text ":=" <+> ppr ty -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * The main environment types -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- We 'stack' these envs through the Reader like monad infastructure -- as we move into an expression (although the change is focused in -- the lcl type). @@ -448,8 +446,8 @@ data RecFieldEnv -- The FieldEnv deals *only* with constructors defined in *this* -- module. For imported modules, we get the same info from the -- TypeEnv -\end{code} +{- Note [Tracking unused binding and imports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We gather two sorts of usage information @@ -473,14 +471,14 @@ We gather two sorts of usage information is unnecessary. This info isn't present in Names. -%************************************************************************ -%* * +************************************************************************ +* * The interface environments Used when dealing with IfaceDecls -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data IfGblEnv = IfGblEnv { -- The type environment for the module being compiled, @@ -512,14 +510,13 @@ data IfLclEnv -- (and coercions) if_id_env :: UniqFM Id -- Nested id binding } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * The local typechecker environment -%* * -%************************************************************************ +* * +************************************************************************ Note [The Global-Env/Local-Env story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -535,8 +532,8 @@ Why? Because they are now Ids not TcIds. This final GlobalEnv is a) fed back (via the knot) to typechecking the unfoldings of interface signatures b) used in the ModDetails of this module +-} -\begin{code} data TcLclEnv -- Changes as we move inside an expression -- Discarded after typecheck/rename; not passed on to desugarer = TcLclEnv { @@ -778,9 +775,8 @@ pprPECategory TyConPE = ptext (sLit "Type constructor") pprPECategory FamDataConPE = ptext (sLit "Data constructor") pprPECategory RecDataConPE = ptext (sLit "Data constructor") pprPECategory NoDataKinds = ptext (sLit "Data constructor") -\end{code} - +{- Note [Bindings with closed types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -817,9 +813,8 @@ Note that: *type variable* Eg f :: forall a. blah f x = let g y = ...(y::a)... +-} - -\begin{code} type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) -- Monadic so that we have a chance -- to deal with bound type variables just before error @@ -827,16 +822,15 @@ type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) -- Bool: True <=> this is a landmark context; do not -- discard it when trimming for display -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Operations over ImportAvails -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | 'ImportAvails' summarises what was imported from where, irrespective of -- whether the imported things are actually used or not. It is used: -- @@ -962,17 +956,17 @@ plusImportAvails = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) -- Check mod-names match (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Where from} -%* * -%************************************************************************ +* * +************************************************************************ The @WhereFrom@ type controls where the renamer looks for an interface file +-} -\begin{code} data WhereFrom = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) | ImportBySystem -- Non user import. @@ -984,18 +978,17 @@ instance Outputable WhereFrom where | otherwise = empty ppr ImportBySystem = ptext (sLit "{- SYSTEM -}") ppr ImportByPlugin = ptext (sLit "{- PLUGIN -}") -\end{code} - -%************************************************************************ -%* * -%* Canonical constraints * -%* * -%* These are the constraints the low-level simplifier works with * -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Canonical constraints * +* * +* These are the constraints the low-level simplifier works with * +* * +************************************************************************ +-} -\begin{code} -- The syntax of xi types: -- xi ::= a | T xis | xis -> xis | ... | forall a. tau -- Two important notes: @@ -1080,8 +1073,7 @@ data Ct data HoleSort = ExprHole -- ^ A hole in an expression (TypedHoles) | TypeHole -- ^ A hole in a type (PartialTypeSignatures) -\end{code} - +{- Note [Kind orientation for CTyEqCan] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given an equality (t:* ~ s:Open), we can't solve it by updating t:=s, @@ -1155,8 +1147,8 @@ built (in TcCanonical). In contrast, the type of the evidence *term* (ccev_evtm or ctev_evar) in the evidence may *not* be fully zonked; we are careful not to look at it during constraint solving. See Note [Evidence field of CtEvidence] +-} -\begin{code} mkNonCanonical :: CtEvidence -> Ct mkNonCanonical ev = CNonCanonical { cc_ev = ev } @@ -1178,8 +1170,8 @@ dropDerivedWC :: WantedConstraints -> WantedConstraints dropDerivedWC wc@(WC { wc_flat = flats }) = wc { wc_flat = filterBag isWantedCt flats } -- The wc_impl implications are already (recursively) filtered -\end{code} +{- Note [Dropping derived constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general we discard derived constraints at the end of constraint solving; @@ -1205,14 +1197,14 @@ we must filter them out when we re-process the WantedConstraint, in TcSimplify.solve_wanteds. -%************************************************************************ -%* * +************************************************************************ +* * CtEvidence The "flavor" of a canonical constraint -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} isWantedCt :: Ct -> Bool isWantedCt = isWanted . cc_ev @@ -1258,9 +1250,7 @@ isTypedHoleCt _ = False isPartialTypeSigCt :: Ct -> Bool isPartialTypeSigCt (CHoleCan { cc_hole = TypeHole }) = True isPartialTypeSigCt _ = False -\end{code} -\begin{code} instance Outputable Ct where ppr ct = ppr (cc_ev ct) <+> parens (text ct_sort) where ct_sort = case ct of @@ -1270,9 +1260,7 @@ instance Outputable Ct where CDictCan {} -> "CDictCan" CIrredEvCan {} -> "CIrredEvCan" CHoleCan {} -> "CHoleCan" -\end{code} -\begin{code} singleCt :: Ct -> Cts singleCt = unitBag @@ -1306,20 +1294,19 @@ isEmptyCts = isEmptyBag pprCts :: Cts -> SDoc pprCts cts = vcat (map ppr (bagToList cts)) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Wanted constraints These are forced to be in TcRnTypes because TcLclEnv mentions WantedConstraints WantedConstraint mentions CtLoc CtLoc mentions ErrCtxt ErrCtxt mentions TcM -%* * +* * v%************************************************************************ - -\begin{code} +-} data WantedConstraints = WC { wc_flat :: Cts -- Unsolved constraints, all wanted @@ -1379,18 +1366,17 @@ instance Outputable WantedConstraints where ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc ppr_bag doc bag | isEmptyBag bag = empty - | otherwise = hang (doc <+> equals) + | otherwise = hang (doc <+> equals) 2 (foldrBag (($$) . ppr) empty bag) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Implication constraints -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data Implication = Implic { ic_tclvl :: TcLevel, -- TcLevel: unification variables @@ -1432,8 +1418,8 @@ instance Outputable Implication where , hang (ptext (sLit "Wanted =")) 2 (ppr wanted) , ptext (sLit "Binds =") <+> ppr binds , pprSkolInfo info ] <+> rbrace) -\end{code} +{- Note [Shadowing in a constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We assume NO SHADOWING in a constraint. Specifically @@ -1487,13 +1473,13 @@ report that. If insolubles did not contain Deriveds, reportErrors would never see it. -%************************************************************************ -%* * +************************************************************************ +* * Pretty printing -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} pprEvVars :: [EvVar] -> SDoc -- Print with their types pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) @@ -1502,21 +1488,21 @@ pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) pprEvVarWithType :: EvVar -> SDoc pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * CtEvidence -%* * -%************************************************************************ +* * +************************************************************************ Note [Evidence field of CtEvidence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During constraint solving we never look at the type of ctev_evtm, or ctev_evar; instead we look at the cte_pred field. The evtm/evar field may be un-zonked. +-} -\begin{code} data CtEvidence = CtGiven { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] , ctev_evtm :: EvTerm -- See Note [Evidence field of CtEvidence] @@ -1577,14 +1563,13 @@ isGiven _ = False isDerived :: CtEvidence -> Bool isDerived (CtDerived {}) = True isDerived _ = False -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * SubGoalDepth -%* * -%************************************************************************ +* * +************************************************************************ Note [SubGoalDepth] ~~~~~~~~~~~~~~~~~~~ @@ -1625,8 +1610,8 @@ Each counter starts at zero and increases. in sensible programs than type class constraints. The flag -ftype-function-depth=n fixes the maximium level. +-} -\begin{code} data SubGoalCounter = CountConstraints | CountTyFunApps data SubGoalDepth -- See Note [SubGoalDepth] @@ -1668,8 +1653,8 @@ ctEvCheckDepth cls target ev , cls == coercibleClass -- The restriction applies only to Coercible = ctLocDepth target <= ctLocDepth (ctEvLoc ev) | otherwise = True -\end{code} +{- Note [Preventing recursive dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: this will go away when we start treating Coercible as an equality. @@ -1693,18 +1678,18 @@ ensures that a Given constraint can always be used to solve a goal (i.e. they are at depth infinity, for our purposes) -%************************************************************************ -%* * +************************************************************************ +* * CtLoc -%* * -%************************************************************************ +* * +************************************************************************ The 'CtLoc' gives information about where a constraint came from. This is important for decent error message reporting because dictionaries don't appear in the original source code. type will evolve... +-} -\begin{code} data CtLoc = CtLoc { ctl_origin :: CtOrigin , ctl_env :: TcLclEnv , ctl_depth :: !SubGoalDepth } @@ -1715,7 +1700,7 @@ data CtLoc = CtLoc { ctl_origin :: CtOrigin -- level: tcl_tclvl :: TcLevel mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc -mkGivenLoc tclvl skol_info env +mkGivenLoc tclvl skol_info env = CtLoc { ctl_origin = GivenOrigin skol_info , ctl_env = env { tcl_tclvl = tclvl } , ctl_depth = initialSubGoalDepth } @@ -1763,15 +1748,15 @@ pprArisingAt :: CtLoc -> SDoc pprArisingAt (CtLoc { ctl_origin = o, ctl_env = lcl}) = sep [ pprCtOrigin o , text "at" <+> ppr (tcl_loc lcl)] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * SkolemInfo -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- SkolemInfo gives the origin of *given* constraints -- a) type variables are skolemised -- b) an implication constraint is generated @@ -1852,16 +1837,15 @@ pprSkolInfo (UnifyForAllSkol tvs ty) = ptext (sLit "the type") <+> ppr (mkForAll -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * CtOrigin -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data CtOrigin = GivenOrigin SkolemInfo @@ -1992,17 +1976,11 @@ pprCtO AnnOrigin = ptext (sLit "an annotation") pprCtO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_") pprCtO ListOrigin = ptext (sLit "an overloaded list") pprCtO _ = panic "pprCtOrigin" -\end{code} - - - - +{- Constraint Solver Plugins ------------------------- - - -\begin{code} +-} type TcPluginSolver = [Ct] -- given -> [Ct] -- derived @@ -2059,5 +2037,3 @@ data TcPluginResult -- and the evidence for them is recorded. -- The second field contains new work, that should be processed by -- the constraint solver. - -\end{code} diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.hs index b5d8b5b77d..7e86e00f0c 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1993-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + TcRules: Typechecking transformation rules +-} -\begin{code} module TcRules ( tcRules ) where import HsSyn @@ -24,8 +24,8 @@ import SrcLoc import Outputable import FastString import Data.List( partition ) -\end{code} +{- Note [Typechecking rules] ~~~~~~~~~~~~~~~~~~~~~~~~~ We *infer* the typ of the LHS, and use that type to *check* the type of @@ -116,9 +116,8 @@ revert to SimplCheck when going under an implication. * Step 4: Simplify the LHS and RHS constraints separately, using the quantified constraints as givens +-} - -\begin{code} tcRules :: [LRuleDecl Name] -> TcM [LRuleDecl TcId] tcRules decls = mapM (wrapLocM tcRule) decls @@ -224,4 +223,3 @@ tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs) ruleCtxt :: FastString -> SDoc ruleCtxt name = ptext (sLit "When checking the transformation rule") <+> doubleQuotes (ftext name) -\end{code} diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.hs index 752bc45129..4775394eef 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.hs @@ -1,4 +1,3 @@ -\begin{code} {-# LANGUAGE CPP, TypeFamilies #-} -- Type definitions for the constraint solver @@ -31,7 +30,7 @@ module TcSMonad ( runTcPluginTcS, -- Getting and setting the flattening cache - addSolvedDict, + addSolvedDict, -- Marking stuff as used addUsedRdrNamesTcS, @@ -40,7 +39,7 @@ module TcSMonad ( setEvBind, XEvTerm(..), - Freshness(..), freshGoals, + Freshness(..), freshGoals, StopOrContinue(..), continueWith, stopWith, andWhenContinue, @@ -49,8 +48,8 @@ module TcSMonad ( rewriteEqEvidence, -- Yet more specialised, for equality coercions maybeSym, - newTcEvBinds, newWantedEvVar, newWantedEvVarNC, - newEvVar, newGivenEvVar, + newTcEvBinds, newWantedEvVar, newWantedEvVarNC, + newEvVar, newGivenEvVar, emitNewDerived, emitNewDerivedEq, instDFunConstraints, @@ -59,7 +58,7 @@ module TcSMonad ( getInstEnvs, getFamInstEnvs, -- Getting the environments getTopEnv, getGblEnv, getTcEvBinds, getTcLevel, - getTcEvBindsMap, + getTcEvBindsMap, lookupFlatCache, newFlattenSkolem, -- Flatten skolems @@ -69,7 +68,7 @@ module TcSMonad ( -- Inerts InertSet(..), InertCans(..), getNoGivenEqs, setInertCans, getInertEqs, getInertCans, - emptyInert, getTcSInerts, setTcSInerts, + emptyInert, getTcSInerts, setTcSInerts, getUnsolvedInerts, checkAllSolved, splitInertCans, removeInertCts, prepareInertsForImplications, @@ -155,16 +154,16 @@ import Pair #ifdef DEBUG import Digraph #endif -\end{code} -%************************************************************************ -%* * -%* Worklists * -%* Canonical and non-canonical constraints that the simplifier has to * -%* work on. Including their simplification depths. * -%* * -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Worklists * +* Canonical and non-canonical constraints that the simplifier has to * +* work on. Including their simplification depths. * +* * +* * +************************************************************************ Note [WorkList priorities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -177,9 +176,8 @@ equalities (wl_eqs) from the rest of the canonical constraints, so that it's easier to deal with them first, but the separation is not strictly necessary. Notice that non-canonical constraints are also parts of the worklist. +-} - -\begin{code} data Deque a = DQ [a] [a] -- Insert in RH field, remove from LH field -- First to remove is at head of LH field @@ -212,7 +210,7 @@ extractDeque (DQ [] bs) = case reverse bs of [] -> panic "extractDeque" -- See Note [WorkList priorities] -data WorkList +data WorkList = WL { wl_eqs :: [Ct] , wl_funeqs :: Deque Ct , wl_rest :: [Ct] @@ -220,7 +218,7 @@ data WorkList } appendWorkList :: WorkList -> WorkList -> WorkList -appendWorkList +appendWorkList (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1, wl_implics = implics1 }) (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2, wl_implics = implics2 }) = WL { wl_eqs = eqs1 ++ eqs2 @@ -234,7 +232,7 @@ workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest }) = length eqs + dequeSize funeqs + length rest extendWorkListEq :: Ct -> WorkList -> WorkList -extendWorkListEq ct wl +extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl } extendWorkListFunEq :: Ct -> WorkList -> WorkList @@ -290,7 +288,7 @@ instance Outputable WorkList where ppr (WL { wl_eqs = eqs, wl_funeqs = feqs , wl_rest = rest, wl_implics = implics }) = text "WL" <+> (braces $ - vcat [ ppUnless (null eqs) $ + vcat [ ppUnless (null eqs) $ ptext (sLit "Eqs =") <+> vcat (map ppr eqs) , ppUnless (isEmptyDeque feqs) $ ptext (sLit "Funeqs =") <+> vcat (map ppr (dequeList feqs)) @@ -299,14 +297,14 @@ instance Outputable WorkList where , ppUnless (isEmptyBag implics) $ ptext (sLit "Implics =") <+> vcat (map ppr (bagToList implics)) ]) -\end{code} -%************************************************************************ -%* * -%* Inert Sets * -%* * -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Inert Sets * +* * +* * +************************************************************************ Note [Detailed InertCans Invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -349,8 +347,8 @@ Type-family equations, of form (ev : F tys ~ ty), live in three places using w3 itself! * The inert_funeqs are un-solved but fully processed and in the InertCans. +-} -\begin{code} -- All Given (fully known) or Wanted or Derived -- See Note [Detailed InertCans Invariants] for more data InertCans @@ -392,7 +390,7 @@ data InertSet , inert_flat_cache :: FunEqMap (TcCoercion, TcTyVar) -- See Note [Type family equations] - -- If F tys :-> (co, fsk), + -- If F tys :-> (co, fsk), -- then co :: F tys ~ fsk -- Just a hash-cons cache for use when flattening only -- These include entirely un-processed goals, so don't use @@ -410,9 +408,7 @@ data InertSet -- - Stored not necessarily as fully rewritten -- (ToDo: rewrite lazily when we lookup) } -\end{code} -\begin{code} instance Outputable InertCans where ppr ics = vcat [ ptext (sLit "Equalities:") <+> pprCts (foldVarEnv (\eqs rest -> listToBag eqs `andCts` rest) @@ -543,8 +539,8 @@ prepareInertsForImplications is@(IS { inert_cans = cans }) is_given_ecl :: EqualCtList -> Bool is_given_ecl (ct:rest) | isGivenCt ct = ASSERT( null rest ) True is_given_ecl _ = False -\end{code} +{- Note [Do not inherit the flat cache] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We do not want to inherit the flat cache when processing nested @@ -552,8 +548,8 @@ implications. Consider a ~ F b, forall c. b~Int => blah If we have F b ~ fsk in the flat-cache, and we push that into the nested implication, we might miss that F b can be rewritten to F Int, -and hence perhpas solve it. Moreover, the fsk from outside is -flattened out after solving the outer level, but and we don't +and hence perhpas solve it. Moreover, the fsk from outside is +flattened out after solving the outer level, but and we don't do that flattening recursively. Note [Preparing inert set for implications] @@ -575,8 +571,8 @@ alpha. (In general we can't float class constraints out just in case For Derived constraints we don't have evidence, so we do not turn them into Givens. There can *be* deriving CFunEqCans; see Trac #8129. +-} -\begin{code} getInertEqs :: TcS (TyVarEnv EqualCtList) getInertEqs = do { inert <- getTcSInerts ; return (inert_eqs (inert_cans inert)) } @@ -649,8 +645,8 @@ getNoGivenEqs tclvl skol_tvs SkolemTv {} -> tv `elemVarSet` skol_tv_set FlatSkol {} -> not (tv `elemVarSet` local_fsks) _ -> False -\end{code} +{- Note [When does an implication have given equalities?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider an implication @@ -709,8 +705,8 @@ b) 'a' will have been completely substituted out in the inert set, returned as part of 'fsks' For an example, see Trac #9211. +-} -\begin{code} splitInertCans :: InertCans -> ([Ct], [Ct], [Ct]) -- ^ Extract the (given, derived, wanted) inert constraints splitInertCans iCans = (given,derived,wanted) @@ -805,16 +801,15 @@ lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys = case findDict solved cls tys of Just ev | ctEvCheckDepth cls loc ev -> Just ev _ -> Nothing -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * TyEqMap -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} type TyEqMap a = TyVarEnv a findTyEqs :: TyEqMap EqualCtList -> TyVar -> EqualCtList @@ -824,16 +819,15 @@ delTyEq :: TyEqMap EqualCtList -> TcTyVar -> TcType -> TyEqMap EqualCtList delTyEq m tv t = modifyVarEnv (filter (not . isThisOne)) m tv where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1 isThisOne _ = False -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * TcAppMap, DictMap, FunEqMap -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} type TcAppMap a = UniqFM (ListMap TypeMap a) -- Indexed by tycon then the arg types -- Used for types and classes; hence UniqFM @@ -980,14 +974,13 @@ partitionFunEqs f m = foldTcAppMap k m (emptyBag, emptyFunEqs) delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a delFunEq m tc tys = delTcApp m (getUnique tc) tys -\end{code} - -%************************************************************************ -%* * -%* The TcS solver monad * -%* * -%************************************************************************ +{- +************************************************************************ +* * +* The TcS solver monad * +* * +************************************************************************ Note [The TcS monad] ~~~~~~~~~~~~~~~~~~~~ @@ -1001,14 +994,14 @@ All you can do is Filling in a dictionary evidence variable means to create a binding for it, so TcS carries a mutable location where the binding can be added. This is initialised from the innermost implication constraint. +-} -\begin{code} data TcSEnv = TcSEnv { tcs_ev_binds :: EvBindsVar, tcs_unified :: IORef Bool, - -- The "dirty-flag" Bool is set True when + -- The "dirty-flag" Bool is set True when -- we unify a unification variable tcs_count :: IORef Int, -- Global step count @@ -1016,9 +1009,6 @@ data TcSEnv tcs_inerts :: IORef InertSet, -- Current inert set tcs_worklist :: IORef WorkList -- Current worklist } -\end{code} - -\begin{code} --------------- newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } @@ -1087,10 +1077,10 @@ traceFireTcS ev doc = TcS $ \env -> csTraceTcM 1 $ do { n <- TcM.readTcRef (tcs_count env) ; tclvl <- TcM.getTcLevel - ; return (hang (int n <> brackets (ptext (sLit "U:") <> ppr tclvl - <> ppr (ctLocDepth (ctEvLoc ev))) + ; return (hang (int n <> brackets (ptext (sLit "U:") <> ppr tclvl + <> ppr (ctLocDepth (ctEvLoc ev))) <+> doc <> colon) - 4 (ppr ev)) } + 4 (ppr ev)) } csTraceTcM :: Int -> TcM SDoc -> TcM () -- Constraint-solver tracing, -ddump-cs-trace @@ -1128,7 +1118,7 @@ runTcSWithEvBinds ev_binds_var tcs ; res <- unTcS tcs env ; count <- TcM.readTcRef step_count - ; when (count > 0) $ + ; when (count > 0) $ csTraceTcM 0 $ return (ptext (sLit "Constraint solver steps =") <+> int count) #ifdef DEBUG @@ -1227,8 +1217,8 @@ tryTcS (TcS thing_inside) , tcs_inerts = is_var , tcs_worklist = wl_var } ; thing_inside nest_env } -\end{code} +{- Note [Propagate the solved dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's really quite important that nestTcS does not discard the solved @@ -1240,8 +1230,8 @@ We solve the flat (Eq [a]), under nestTcS, and then turn our attention to the implications. It's definitely fine to use the solved dictionaries on the inner implications, and it can make a signficant performance difference if you do so. +-} -\begin{code} -- Getters and setters of TcEnv fields -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1309,9 +1299,7 @@ getTcEvBinds = TcS (return . tcs_ev_binds) getTcLevel :: TcS TcLevel getTcLevel = wrapTcS TcM.getTcLevel -\end{code} -\begin{code} getTcEvBindsMap :: TcS EvBindMap getTcEvBindsMap = do { EvBindsVar ev_ref _ <- getTcEvBinds @@ -1341,9 +1329,7 @@ reportUnifications (TcS thing_inside) ; res <- thing_inside (env { tcs_unified = inner_unified }) ; dirty <- TcM.readTcRef inner_unified ; return (dirty, res) } -\end{code} -\begin{code} getDefaultInfo :: TcS ([Type], (Bool, Bool)) getDefaultInfo = wrapTcS TcM.tcGetDefaultTys @@ -1413,9 +1399,8 @@ zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv) zonkFlats :: Cts -> TcS Cts zonkFlats cts = wrapTcS (TcM.zonkFlats cts) -\end{code} - +{- Note [Do not add duplicate derived insolubles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general we *must* add an insoluble (Int ~ Bool) even if there is @@ -1464,10 +1449,8 @@ which will result in two Deriveds to end up in the insoluble set: wc_flat = D [c] c [W] wc_insols = (c ~ [c]) [D], (c ~ [c]) [D] +-} - - -\begin{code} -- Flatten skolems -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ newFlattenSkolem :: CtEvidence -> TcType -- F xis @@ -1641,9 +1624,8 @@ newDerived loc pred instDFunConstraints :: CtLoc -> TcThetaType -> TcS [(CtEvidence, Freshness)] instDFunConstraints loc = mapM (newWantedEvVar loc) -\end{code} - +{- Note [xCtEvidence] ~~~~~~~~~~~~~~~~~~ A call might look like this: @@ -1708,15 +1690,15 @@ with un-equal kinds, e.g. [G] t1::k1 ~ t2::k2 -- k1 and k2 are un-equal kinds Reason: k1 or k2 might be unification variables that have already been unified (at this point we have not canonicalised the types), so we want -to emit this t1~t2 as a (non-canonical) Given in the work-list. If k1/k2 -have been unified, we'll find that when we canonicalise it, and the +to emit this t1~t2 as a (non-canonical) Given in the work-list. If k1/k2 +have been unified, we'll find that when we canonicalise it, and the t1~t2 information may be crucial (Trac #8705 is an example). If it turns out that k1 and k2 are really un-equal, then it'll end up as an Irreducible (see Note [Equalities with incompatible kinds] in TcCanonical), and will do no harm. +-} -\begin{code} xCtEvidence :: CtEvidence -- Original evidence -> XEvTerm -- Instructions about how to manipulate evidence -> TcS () @@ -1874,7 +1856,7 @@ rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swap rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co | CtDerived { ctev_loc = loc } <- old_ev = do { mb <- newDerived loc (mkTcEqPred nlhs nrhs) - ; case mb of + ; case mb of Just new_ev -> continueWith new_ev Nothing -> stopWith old_ev "Cached derived" } @@ -1884,7 +1866,7 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co = return (ContinueWith (old_ev { ctev_pred = new_pred })) | CtGiven { ctev_evtm = old_tm , ctev_loc = loc } <- old_ev - = do { let new_tm = EvCoercion (lhs_co + = do { let new_tm = EvCoercion (lhs_co `mkTcTransCo` maybeSym swapped (evTermCoercion old_tm) `mkTcTransCo` mkTcSymCo rhs_co) ; new_ev <- newGivenEvVar loc (new_pred, new_tm) -- See Note [Bind new Givens immediately] @@ -1941,20 +1923,18 @@ matchFam tycon args | otherwise = return Nothing -\end{code} - +{- Note [Residual implications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The wl_implics in the WorkList are the residual implication constraints that are generated while solving or canonicalising the current worklist. Specifically, when canonicalising - (forall a. t1 ~ forall a. t2) + (forall a. t1 ~ forall a. t2) from which we get the implication (forall a. t1 ~ t2) See TcSMonad.deferTcSForAllEq +-} - -\begin{code} -- Deferring forall equalities as implications -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2000,5 +1980,3 @@ deferTcSForAllEq role loc (tvs1,body1) (tvs2,body2) ; return (TcLetCo ev_binds new_co) } ; return $ EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs) } -\end{code} - diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.hs index 90924e7aa7..f9b891f993 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.hs @@ -1,8 +1,7 @@ -\begin{code} {-# LANGUAGE CPP #-} module TcSimplify( - simplifyInfer, + simplifyInfer, quantifyPred, growThetaTyVars, simplifyAmbiguityCheck, simplifyDefault, @@ -43,16 +42,15 @@ import Outputable import FastString import TrieMap () -- DV: for now import Data.List( partition ) -\end{code} - +{- ********************************************************************************* * * * External interface * * * ********************************************************************************* +-} -\begin{code} simplifyTop :: WantedConstraints -> TcM (Bag EvBind) -- Simplify top-level constraints -- Usually these will be implications, @@ -99,7 +97,7 @@ simpl_top wanteds try_class_defaulting :: WantedConstraints -> TcS WantedConstraints try_class_defaulting wc - | isEmptyWC wc + | isEmptyWC wc = return wc | otherwise -- See Note [When to do type-class defaulting] = do { something_happened <- applyDefaultingRules (approximateWC wc) @@ -108,8 +106,8 @@ simpl_top wanteds then do { wc_residual <- nestTcS (solveWantedsAndDrop wc) ; try_class_defaulting wc_residual } else return wc } -\end{code} +{- Note [When to do type-class defaulting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC @@ -125,12 +123,12 @@ So it seems better to always do type-class defaulting. However, always doing defaulting does mean that we'll do it in situations like this (Trac #5934): run :: (forall s. GenST s) -> Int - run = fromInteger 0 + run = fromInteger 0 We don't unify the return type of fromInteger with the given function type, because the latter involves foralls. So we're left with (Num alpha, alpha ~ (forall s. GenST s) -> Int) -Now we do defaulting, get alpha := Integer, and report that we can't -match Integer with (forall s. GenST s) -> Int. That's not totally +Now we do defaulting, get alpha := Integer, and report that we can't +match Integer with (forall s. GenST s) -> Int. That's not totally stupid, but perhaps a little strange. Another potential alternative would be to suppress *all* non-insoluble @@ -185,8 +183,8 @@ defaulting. Again this is done at the top-level and the plan is: - Apply defaulting to their kinds More details in Note [DefaultTyVar]. +-} -\begin{code} ------------------ simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () simplifyAmbiguityCheck ty wanteds @@ -229,9 +227,8 @@ simplifyDefault theta ; traceTc "reportUnsolved }" empty ; return () } -\end{code} - +{- ********************************************************************************* * * * Inference @@ -256,8 +253,8 @@ To infer f's type we do the following: This ensures that the implication constraint we generate, if any, has a strictly-increased level compared to the ambient level outside the let binding. +-} -\begin{code} simplifyInfer :: TcLevel -- Used when generating the constraints -> Bool -- Apply monomorphism restriction -> [(Name, TcTauType)] -- Variables to be generalised, @@ -378,22 +375,21 @@ simplifyInfer rhs_tclvl apply_mr name_taus wanteds , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs , ptext (sLit "promote_tvs=") <+> ppr promote_tvs , ptext (sLit "bound =") <+> ppr bound - , ptext (sLit "minimal_bound =") <+> vcat [ ppr v <+> dcolon <+> ppr (idType v) + , ptext (sLit "minimal_bound =") <+> vcat [ ppr v <+> dcolon <+> ppr (idType v) | v <- minimal_bound_ev_vars] , ptext (sLit "mr_bites =") <+> ppr mr_bites , ptext (sLit "qtvs =") <+> ppr qtvs , ptext (sLit "implic =") <+> ppr implic ] ; return ( qtvs, minimal_bound_ev_vars - , mr_bites, TcEvBinds ev_binds_var) } + , mr_bites, TcEvBinds ev_binds_var) } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Quantification -%* * -%************************************************************************ +* * +************************************************************************ Note [Deciding quantification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -413,10 +409,8 @@ If the monomorphism restriction does not apply, then we quantify as follows: If the MR does apply, mono_tvs includes all the constrained tyvars, and the quantified constraints are empty. +-} - - -\begin{code} decideQuantification :: Bool -> [PredType] -> TcTyVarSet -> TcM ( TcTyVarSet -- Promote these , [TcTyVar] -- Do quantify over these @@ -484,8 +478,8 @@ growThetaTyVars theta tvs | otherwise = tvs where pred_tvs = tyVarsOfType pred -\end{code} +{- Note [Growing the tau-tvs using constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (growThetaTyVars insts tvs) is the result of extending the set @@ -632,8 +626,8 @@ Deciding which equalities to quantify over is tricky: The difficulty is that it's hard to tell what is insoluble! So we see whether the simplificaiotn step yielded any type errors, and if so refrain from quantifying over *any* equalites. +-} -\begin{code} simplifyRule :: RuleName -> WantedConstraints -- Constraints from LHS -> WantedConstraints -- Constraints from RHS @@ -667,9 +661,8 @@ simplifyRule name lhs_wanted rhs_wanted ; return ( map (ctEvId . ctEvidence) (bagToList q_cts) , lhs_wanted { wc_flat = non_q_cts }) } -\end{code} - +{- ********************************************************************************* * * * Main Simplifier * @@ -722,8 +715,8 @@ a) because zonkWC generates evidence, and this is the moment when we Note that *after* solving the constraints are typically small, so the overhead is not great. +-} -\begin{code} solveWantedsTcMWithEvBinds :: EvBindsVar -> WantedConstraints -> (WantedConstraints -> TcS WantedConstraints) @@ -811,7 +804,7 @@ simpl_loop n wanteds@(WC { wc_flat = flats, wc_insol = insols, wc_impl = implics else do { -- Put floated_eqs into the current inert set before looping - (unifs_happened, solve_flat_res) + (unifs_happened, solve_flat_res) <- reportUnifications $ solveFlats (WC { wc_flat = floated_eqs `unionBags` flats -- Put floated_eqs first so they get solved first @@ -823,7 +816,7 @@ simpl_loop n wanteds@(WC { wc_flat = flats, wc_insol = insols, wc_impl = implics , wc_impl = unsolved_implics } ; if not unifs_happened -- See Note [Cutting off simpl_loop] - && isEmptyBag (wc_impl solve_flat_res) + && isEmptyBag (wc_impl solve_flat_res) then return new_wanteds else simpl_loop (n+1) new_wanteds } } @@ -835,7 +828,7 @@ solveNestedImplications implics | isEmptyBag implics = return (emptyBag, emptyBag) | otherwise - = do { + = do { -- inerts <- getTcSInerts -- ; let thinner_inerts = prepareInertsForImplications inerts -- -- See Note [Preparing inert set for implications] @@ -906,8 +899,8 @@ solveImplication imp@(Implic { ic_tclvl = tclvl , text "implication evbinds = " <+> ppr (evBindMapBinds evbinds) ] ; return (floated_eqs, res_implic) } -\end{code} +{- Note [Cutting off simpl_loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is very important not to iterate in simpl_loop unless there is a chance @@ -945,8 +938,8 @@ Consider floated_eqs (all wanted or derived): [Preparing inert set for implications] in TcSMonad. But because of that very fact, we won't generate another copy if we iterate simpl_loop. So we iterate if there any of these +-} -\begin{code} promoteTyVar :: TcLevel -> TcTyVar -> TcS () -- When we float a constraint out of an implication we must restore -- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType @@ -1013,8 +1006,8 @@ approximateWC wc new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp do_bag :: (a -> Bag c) -> Bag a -> Bag c do_bag f = foldrBag (unionBags.f) emptyBag -\end{code} +{- Note [ApproximateWC] ~~~~~~~~~~~~~~~~~~~~ approximateWC takes a constraint, typically arising from the RHS of a @@ -1222,23 +1215,22 @@ Principle: Consequence: classes with functional dependencies don't matter (since there is no evidence for a fundep equality), but equality superclasses do matter (since they carry evidence). +-} - -\begin{code} floatEqualities :: [TcTyVar] -> Bool -> WantedConstraints -> TcS (Cts, WantedConstraints) -- Main idea: see Note [Float Equalities out of Implications] -- --- Precondition: the wc_flat of the incoming WantedConstraints are +-- Precondition: the wc_flat of the incoming WantedConstraints are -- fully zonked, so that we can see their free variables -- --- Postcondition: The returned floated constraints (Cts) are only --- Wanted or Derived and come from the input wanted +-- Postcondition: The returned floated constraints (Cts) are only +-- Wanted or Derived and come from the input wanted -- ev vars or deriveds -- -- Also performs some unifications (via promoteTyVar), adding to --- monadically-carried ty_binds. These will be used when processing +-- monadically-carried ty_binds. These will be used when processing -- floated_eqs later -- -- Subtleties: Note [Float equalities from under a skolem binding] @@ -1283,8 +1275,8 @@ floatEqualities skols no_given_eqs wanteds@(WC { wc_flat = flats }) where k1 = typeKind ty1 k2 = typeKind ty2 -\end{code} +{- Note [Do not float kind-incompatible equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have (t::* ~ s::*->*), we'll get a Derived insoluble equality. @@ -1337,8 +1329,8 @@ to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be. * Defaulting and disamgiguation * * * ********************************************************************************* +-} -\begin{code} applyDefaultingRules :: Cts -> TcS Bool -- True <=> I did some defaulting, reflected in ty_binds @@ -1360,11 +1352,7 @@ applyDefaultingRules wanteds ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) ; return (or something_happeneds) } -\end{code} - - -\begin{code} findDefaultableGroups :: ( [Type] , (Bool,Bool) ) -- (Overloaded strings, extended default rules) @@ -1456,8 +1444,8 @@ disambigGroup (default_ty:default_tys) group loc = CtLoc { ctl_origin = GivenOrigin UnkSkol , ctl_env = panic "disambigGroup:env" , ctl_depth = initialSubGoalDepth } -\end{code} +{- Note [Avoiding spurious errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When doing the unification for defaulting, we check for skolem @@ -1470,4 +1458,4 @@ that g isn't polymorphic enough; but then we get another one when dealing with the (Num a) context arising from f's definition; we try to unify a with Int (to default it), but find that it's already been unified with the rigid variable from g's type sig - +-} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.hs index 247d55c182..a2ff9777b0 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.hs @@ -1,12 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -TcSplice: Template Haskell splices +TcSplice: Template Haskell splices +-} -\begin{code} {-# LANGUAGE CPP, FlexibleInstances, MagicHash, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -110,15 +109,15 @@ import Data.Typeable ( typeOf ) import Data.Data (Data) import GHC.Exts ( unsafeCoerce# ) #endif -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Main interface + stubs for the non-GHCI case -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId) tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) @@ -144,9 +143,8 @@ runAnnotation _ q = failTH q "annotation" #else -- The whole of the rest of the file is the else-branch (ie stage2 only) -\end{code} - +{- Note [How top-level splices are handled] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Top-level splices (those not inside a [| .. |] quotation bracket) are handled @@ -328,14 +326,13 @@ When a variable is used, we compare g2 = $(f ...) is not OK; because we havn't compiled f yet -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Quoting an expression} -%* * -%************************************************************************ - +* * +************************************************************************ +-} -\begin{code} -- See Note [How brackets and nested splices are handled] -- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) tcTypedBracket brack@(TExpBr expr) res_ty @@ -414,16 +411,15 @@ tcTExpTy tau = do q <- tcLookupTyCon qTyConName texp <- tcLookupTyCon tExpTyConName return (mkTyConApp q [mkTyConApp texp [tau]]) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Splicing an expression} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcSpliceExpr splice@(HsSplice name expr) res_ty = addErrCtxt (spliceCtxtDoc splice) $ setSrcSpan (getLoc expr) $ do @@ -472,16 +468,15 @@ tcTopSplice expr res_ty { (exp3, _fvs) <- rnLExpr expr2 ; exp4 <- tcMonoExpr exp3 res_ty ; return (unLoc exp4) } } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Error messages} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} quotationCtxtDoc :: HsBracket Name -> SDoc quotationCtxtDoc br_body = hang (ptext (sLit "In the Template Haskell quotation")) @@ -527,15 +522,15 @@ tcTopSpliceExpr isTypedSplice tc_action -- Zonk it and tie the knot of dictionary bindings ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Annotations -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} runAnnotation target expr = do -- Find the classes we want instances for in order to call toAnnotationWrapper loc <- getSrcSpanM @@ -573,14 +568,13 @@ runAnnotation target expr = do ann_target = target, ann_value = serialized } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Quasi-quoting -%* * -%************************************************************************ +* * +************************************************************************ Note [Quasi-quote overview] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -599,15 +593,15 @@ a bit like a TH splice: However, you can do this in patterns as well as terms. Because of this, the splice is run by the *renamer* rather than the type checker. -%************************************************************************ -%* * +************************************************************************ +* * \subsubsection{Quasiquotation} -%* * -%************************************************************************ +* * +************************************************************************ See Note [Quasi-quote overview] in TcSplice. +-} -\begin{code} runQuasiQuote :: Outputable hs_syn => HsQuasiQuote RdrName -- Contains term of type QuasiQuoter, and the String -> Name -- Of type QuasiQuoter -> String -> Q th_syn @@ -678,22 +672,18 @@ deprecatedDollar quoter = hang (ptext (sLit "Deprecated syntax:")) 2 (ptext (sLit "quasiquotes no longer need a dollar sign:") <+> ppr quoter) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Running an expression} -%* * -%************************************************************************ +* * +************************************************************************ +-} - -\begin{code} runQuasi :: TH.Q a -> TcM a runQuasi act = TH.runQ act -\end{code} -\begin{code} data MetaOps th_syn hs_syn = MT { mt_desc :: String -- Type of beast (expression, type etc) , mt_show :: th_syn -> String -- How to show the th_syn thing @@ -819,8 +809,8 @@ runMeta show_code run_and_convert expr nest 2 (text exn_msg), if show_code then text "Code:" <+> ppr expr else empty] failWithTc msg -\end{code} +{- Note [Exceptions in TH] ~~~~~~~~~~~~~~~~~~~~~~~ Supppose we have something like this @@ -873,8 +863,8 @@ when showing an error message. To call runQ in the Tc monad, we need to make TcM an instance of Quasi: +-} -\begin{code} instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where qNewName s = do { u <- newUnique ; let i = getKey u @@ -965,16 +955,15 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where qPutQ x = do th_state_var <- fmap tcg_th_state getGblEnv updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Errors and contexts} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} showSplice :: String -> LHsExpr Name -> SDoc -> TcM () -- Note that 'before' is *renamed* but not *typechecked* -- Reason (a) less typechecking crap @@ -987,16 +976,15 @@ showSplice what before after nest 2 (sep [nest 2 (ppr before), text "======>", nest 2 after])]) } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Instance Testing -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] reifyInstances th_nm th_tys = addErrCtxt (ptext (sLit "In the argument of reifyInstances:") @@ -1043,17 +1031,15 @@ reifyInstances th_nm th_tys cvt loc th_ty = case convertToHsType loc th_ty of Left msg -> failWithTc msg Right ty -> return ty -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Reification -%* * -%************************************************************************ +* * +************************************************************************ +-} - -\begin{code} lookupName :: Bool -- True <=> type namespace -- False <=> value namespace -> String -> TcM (Maybe TH.Name) @@ -1506,8 +1492,7 @@ reifyTyVars tvs = mapM reify_tv $ filter isTypeVar tvs kind = tyVarKind tv name = reifyName tv -\end{code} - +{- Note [Kind annotations on TyConApps] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A poly-kinded tycon sometimes needs a kind annotation to be unambiguous. @@ -1542,8 +1527,7 @@ rare special case, and we conservatively choose to put the annotation in. See #8953 and test th/T8953. - -\begin{code} +-} reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type reify_tc_app tc tys @@ -1696,8 +1680,8 @@ noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+> ppr_th :: TH.Ppr a => a -> SDoc ppr_th x = text (TH.pprint x) -\end{code} +{- Note [Reifying data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Template Haskell syntax is rich enough to express even GADTs, @@ -1712,7 +1696,6 @@ will appear in TH syntax like this data T a = forall b. (a ~ [b]) => MkT1 b | (a ~ Int) => MkT2 +-} -\begin{code} #endif /* GHCI */ -\end{code} diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.hs-boot index fd19dee7da..cff4dc9c56 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.hs-boot @@ -1,4 +1,3 @@ -\begin{code} {-# LANGUAGE CPP #-} module TcSplice where @@ -45,4 +44,3 @@ runMetaD :: LHsExpr Id -> TcM [LHsDecl RdrName] lookupThName_maybe :: TH.Name -> TcM (Maybe Name) runQuasi :: TH.Q a -> TcM a #endif -\end{code} diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.hs index ca69856fe8..2ff482c371 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1996-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + TcTyClsDecls: Typecheck type and class declarations +-} -\begin{code} {-# LANGUAGE CPP, TupleSections #-} module TcTyClsDecls ( @@ -71,14 +71,13 @@ import BasicTypes import Bag import Control.Monad import Data.List -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Type checking for type and class declarations} -%* * -%************************************************************************ +* * +************************************************************************ Note [Grouping of type and class declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -107,8 +106,7 @@ be ill-formed (see #7175 and Note [Checking GADT return types]) we must check *all* the tycons in a group for validity before checking *any* of the roles. Thus, we take two passes over the resulting tycons, first checking for general validity and then checking for valid role annotations. - -\begin{code} +-} tcTyAndClassDecls :: ModDetails -> [TyClGroup Name] -- Mutually-recursive groups in dependency order @@ -202,14 +200,13 @@ zipRecTyClss kind_pairs rec_things get name = case lookupTypeEnv rec_type_env name of Just (ATyCon tc) -> tc other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Kind checking -%* * -%************************************************************************ +* * +************************************************************************ Note [Kind checking for type and class decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -263,8 +260,8 @@ kind environment (as constructed by `getInitialKind'). In fact, we ignore instances of families altogether in the following. However, we need to include the kinds of *associated* families into the construction of the initial kind environment. (This is handled by `allDecls'). +-} -\begin{code} kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind)] -- Kind check this group, kind generalize, and return the resulting local env -- This bindds the TyCons and Classes of the group, but not the DataCons @@ -516,8 +513,8 @@ kcConDecl (ConDecl { con_names = names, con_qvars = ex_tvs ; _ <- tcConRes res ; return (panic "kcConDecl", ()) } ; return () } -\end{code} +{- Note [Recursion and promoting data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't want to allow promotion in a strongly connected component @@ -535,11 +532,11 @@ ANothing is only used for DataCons, and only used during type checking in tcTyClGroup. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Type checking} -%* * -%************************************************************************ +* * +************************************************************************ Note [Type checking recursive type and class declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -584,8 +581,8 @@ Then: This fancy footwork (with two bindings for T) is only necesary for the TyCons or Classes of this recursive group. Earlier, finished groups, live in the global env only. +-} -\begin{code} tcTyClDecl :: RecTyInfo -> LTyClDecl Name -> TcM [TyThing] tcTyClDecl rec_info (L loc decl) = setSrcSpan loc $ tcAddDeclCtxt decl $ @@ -665,9 +662,7 @@ tcTyClDecl1 _parent rec_info ; case getTyVar_maybe ty of Just tv' -> return tv' Nothing -> pprPanic "tc_fd_tyvar" (ppr name $$ ppr tv $$ ppr ty) } -\end{code} -\begin{code} tcFamDecl1 :: TyConParent -> FamilyDecl Name -> TcM [TyThing] tcFamDecl1 parent (FamilyDecl {fdInfo = OpenTypeFamily, fdLName = L _ tc_name, fdTyVars = tvs}) @@ -798,14 +793,14 @@ tcDataDefn rec_info tc_name tvs kind (rti_promotable rec_info) gadt_syntax NoParentTyCon) } ; return [ATyCon tycon] } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Typechecking associated types (in class decls) (including the associated-type defaults) -%* * -%************************************************************************ +* * +************************************************************************ Note [Associated type defaults] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -822,8 +817,8 @@ Note that: - We can have more than one default definition for a single associated type, as long as they do not overlap (same rules as for instances) - We can get default definitions only for type families, not data families +-} -\begin{code} tcClassATs :: Name -- The class name (not knot-tied) -> TyConParent -- The class parent of this associated type -> [LFamilyDecl Name] -- Associated types. @@ -931,8 +926,8 @@ kcResultKind Nothing res_k kcResultKind (Just k) res_k = do { k' <- tcLHsKind k ; checkKind k' res_k } -\end{code} +{- Kind check type patterns and kind annotate the embedded type variables. type instance F [a] = rhs @@ -973,8 +968,8 @@ two bad things could happen: *type* checking (as opposed to kind checking) 2) If we just keep blindly forging forward after both kind checking and type checking, we can get a panic in rejigConRes. See Trac #8368. +-} -\begin{code} ----------------- type FamTyConShape = (Name, Arity, Kind) -- See Note [Type-checking type patterns] @@ -1060,8 +1055,8 @@ tcFamTyPats fam_shape@(name,_,_) pats kind_checker thing_inside -- don't print out too much, as we might be in the knot ; tcExtendTyVarEnv qtkvs' $ thing_inside qtkvs' all_args' res_kind' } -\end{code} +{- Note [Quantifying over family patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to quantify over two different lots of kind variables: @@ -1106,13 +1101,13 @@ none. The role of the kind signature (a :: Maybe k) is to add a constraint that 'a' must have that kind, and to bring 'k' into scope. -%************************************************************************ -%* * +************************************************************************ +* * Data types -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM Bool dataDeclChecks tc_name new_or_data stupid_theta cons = do { -- Check that we don't use GADT syntax in H98 world @@ -1262,8 +1257,7 @@ tcConRes ResTyH98 = return ResTyH98 tcConRes (ResTyGADT res_ty) = do { res_ty' <- tcHsLiftedType res_ty ; return (ResTyGADT res_ty') } -\end{code} - +{- Note [Infix GADT constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We do not currently have syntax to declare an infix constructor in GADT syntax, @@ -1300,8 +1294,7 @@ work -- it will have a failed pattern match. Luckily, if we run checkValidDataCon before ever looking at the rejigged return type (checkValidDataCon checks the dataConUserType, which is not rejigged!), we catch the error before forcing the rejigged type and panicking. - -\begin{code} +-} -- Example -- data instance T (b,c) where @@ -1360,8 +1353,8 @@ rejigConRes tmpl_tvs res_tmpl dc_tvs (ResTyGADT res_ty) new_tmpl = updateTyVarKind (substTy subst) tmpl | otherwise = pprPanic "tcResultType" (ppr res_ty) ex_tvs = dc_tvs `minusList` univ_tvs -\end{code} +{- Note [Substitution in template variables kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1396,16 +1389,16 @@ which is why we create new_tmpl. The template substitution only maps kind variables to kind variables, since GADTs are not kind indexed. -%************************************************************************ -%* * +************************************************************************ +* * Validity checking -%* * -%************************************************************************ +* * +************************************************************************ Validity checking is done once the mutually-recursive knot has been tied, so we can look at things freely. +-} -\begin{code} checkClassCycleErrs :: Class -> TcM () checkClassCycleErrs cls = mapM_ recClsErr (calcClassCycles cls) @@ -1730,8 +1723,8 @@ checkFamFlag tc_name where err_msg = hang (ptext (sLit "Illegal family declaration for") <+> quotes (ppr tc_name)) 2 (ptext (sLit "Use TypeFamilies to allow indexed type families")) -\end{code} +{- Note [Abort when superclass cycle is detected] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must avoid doing the ambiguity check for the methods (in @@ -1746,13 +1739,13 @@ representative example: This fixes Trac #9415, #9739 -%************************************************************************ -%* * +************************************************************************ +* * Checking role validity -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} checkValidRoleAnnots :: RoleAnnots -> TyThing -> TcM () checkValidRoleAnnots role_annots thing = case thing of @@ -1871,15 +1864,14 @@ checkValidRoles tc doc, ptext (sLit "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug")] -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Building record selectors -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkDefaultMethodIds :: [TyThing] -> [Id] -- See Note [Default method Ids and Template Haskell] mkDefaultMethodIds things @@ -1887,8 +1879,8 @@ mkDefaultMethodIds things | ATyCon tc <- things , Just cls <- [tyConClass_maybe tc] , (sel_id, DefMeth dm_name) <- classOpItems cls ] -\end{code} +{- Note [Default method Ids and Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (Trac #4169): @@ -1904,8 +1896,8 @@ When we typecheck 'ast' we have done the first pass over the class decl declarations (because they can mention value declarations). So we must bring the default method Ids into scope first (so they can be seen when typechecking the [d| .. |] quote, and typecheck them later. +-} -\begin{code} mkRecSelBinds :: [TyThing] -> HsValBinds Name -- NB We produce *un-typechecked* bindings, rather like 'deriving' -- This makes life easier, because the later type checking will add @@ -1991,8 +1983,8 @@ tyConFields :: TyCon -> [FieldLabel] tyConFields tc | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc)) | otherwise = [] -\end{code} +{- Note [Polymorphic selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When a record has a polymorphic field, we pull the foralls out to the front. @@ -2082,13 +2074,13 @@ The selector we want for fld looks like this: The scrutinee of the case has type :R7T (Maybe b), which can be gotten by appying the eq_spec to the univ_tvs of the data con. -%************************************************************************ -%* * +************************************************************************ +* * Error messages -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a tcAddTyFamInstCtxt decl = tcAddFamInstCtxt (ptext (sLit "type instance")) (tyFamInstDeclName decl) @@ -2306,5 +2298,3 @@ addRoleAnnotCtxt :: Name -> TcM a -> TcM a addRoleAnnotCtxt name = addErrCtxt $ text "while checking a role annotation for" <+> quotes (ppr name) - -\end{code} diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.hs index 3f8b234777..f7cde08c7b 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.hs @@ -1,14 +1,14 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1999 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 + Analysis functions over data types. Specficially, detecting recursive types. This stuff is only used for source-code decls; it's recorded in interface files for imported data types. +-} -\begin{code} {-# LANGUAGE CPP #-} module TcTyDecls( @@ -49,14 +49,13 @@ import Control.Applicative (Applicative(..)) #endif import Control.Monad -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Cycles in class and type synonym declarations -%* * -%************************************************************************ +* * +************************************************************************ Checking for class-decl loops is easy, because we don't allow class decls in interface files. @@ -115,8 +114,8 @@ synonymTyConsOfType ty | otherwise = go_s tys go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys ---------------------------------------- END NOTE ] +-} -\begin{code} mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])] mkSynEdges syn_decls = [ (ldecl, name, nameSetElems fvs) | ldecl@(L _ (SynDecl { tcdLName = L _ name @@ -124,8 +123,8 @@ mkSynEdges syn_decls = [ (ldecl, name, nameSetElems fvs) calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges -\end{code} +{- Note [Superclass cycle check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can't allow cycles via superclasses because it would result in the @@ -182,8 +181,8 @@ third component of the union is like Eqn (1). Eqn (3) happens mainly when the context is a (constraint) tuple, such as (Eq a, Show a). Furthermore, expand always looks through type synonyms. +-} -\begin{code} calcClassCycles :: Class -> [[TyCon]] calcClassCycles cls = nubBy eqAsCycle $ @@ -241,14 +240,13 @@ calcClassCycles cls papp tvs [] = ([], Left tvs) papp (tv:tvs) (ty:tys) = ((tv, ty):env, remainder) where (env, remainder) = papp tvs tys -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Deciding which type constructors are recursive -%* * -%************************************************************************ +* * +************************************************************************ Identification of recursive TyCons ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -355,8 +353,8 @@ unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necess This in turn means that we grovel through fewer interface files when computing recursiveness, because we need only look at the type decls in the module being compiled, plus the outer structure of directly-mentioned types. +-} -\begin{code} data RecTyInfo = RTI { rti_promotable :: Bool , rti_roles :: Name -> [Role] , rti_is_rec :: Name -> RecFlag } @@ -463,14 +461,13 @@ findLoopBreakers deps go edges = [ name | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompFromEdgedVerticesR edges, name <- tyConName tc : go edges'] -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Promotion calculation -%* * -%************************************************************************ +* * +************************************************************************ See Note [Checking whether a group is promotable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -484,8 +481,8 @@ do one pass to check that each TyCon is promotable. Currently type synonyms are not promotable, though that could change. +-} -\begin{code} isPromotableTyCon :: NameSet -> TyCon -> Bool isPromotableTyCon rec_tycons tc = isAlgTyCon tc -- Only algebraic; not even synonyms @@ -525,15 +522,15 @@ isPromotableType rec_tcs con_arg_ty go (FunTy arg res) = go arg && go res go (TyVarTy {}) = True go _ = False -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Role annotations -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} type RoleAnnots = NameEnv (LRoleAnnotDecl Name) extractRoleAnnots :: TyClGroup Name -> RoleAnnots @@ -547,13 +544,12 @@ emptyRoleAnnots = emptyNameEnv lookupRoleAnnots :: RoleAnnots -> Name -> Maybe (LRoleAnnotDecl Name) lookupRoleAnnots = lookupNameEnv -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Role inference -%* * -%************************************************************************ +* * +************************************************************************ Note [Role inference] ~~~~~~~~~~~~~~~~~~~~~ @@ -648,8 +644,8 @@ so we need to take into account * the arguments: (F a) and (a->a) * the context: C a b * the result type: (G a) -- this is in the eq_spec +-} -\begin{code} type RoleEnv = NameEnv [Role] -- from tycon names to roles -- This, and any of the functions it calls, must *not* look at the roles @@ -851,5 +847,3 @@ updateRoleEnv name n role role_env' = extendNameEnv role_env name roles' in RIS { role_env = role_env', update = True } else state ) - -\end{code} diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.hs index 3d38e42e0a..74c5ff4b48 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.hs @@ -1,7 +1,7 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + \section[TcType]{Types used in the typechecker} This module provides the Type interface for front-end parts of the @@ -13,8 +13,8 @@ compiler. These parts The "tc" prefix is for "TypeChecker", because the type checker is the principal client. +-} -\begin{code} {-# LANGUAGE CPP #-} module TcType ( @@ -33,8 +33,8 @@ module TcType ( TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, MetaDetails(Flexi, Indirect), MetaInfo(..), isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, - isSigTyVar, isOverlappableTyVar, isTyConableTyVar, - isFskTyVar, isFmvTyVar, isFlattenTyVar, + isSigTyVar, isOverlappableTyVar, isTyConableTyVar, + isFskTyVar, isFmvTyVar, isFlattenTyVar, isAmbiguousTyVar, metaTvRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, isTypeVar, isKindVar, @@ -183,13 +183,13 @@ import Control.Monad (liftM, ap) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative (Applicative(..)) #endif -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Types} -%* * -%************************************************************************ +* * +************************************************************************ The type checker divides the generic Type world into the following more structured beasts: @@ -219,8 +219,8 @@ tau ::= tyvar -- In all cases, a (saturated) type synonym application is legal, -- provided it expands to the required form. +-} -\begin{code} type TcTyVar = TyVar -- Used only during type inference type TcCoVar = CoVar -- Used only during type inference; mutable type TcType = Type -- A TcType can have mutable type variables @@ -237,8 +237,8 @@ type TcRhoType = TcType -- Note [TcRhoType] type TcTauType = TcType type TcKind = Kind type TcTyVarSet = TyVarSet -\end{code} +{- Note [TcRhoType] ~~~~~~~~~~~~~~~~ A TcRhoType has no foralls or contexts at the top, or to the right of an arrow @@ -248,11 +248,11 @@ A TcRhoType has no foralls or contexts at the top, or to the right of an arrow NO Int -> forall a. a -> Int -%************************************************************************ -%* * +************************************************************************ +* * \subsection{TyVarDetails} -%* * -%************************************************************************ +* * +************************************************************************ TyVarDetails gives extra info about type variables, used during type checking. It's attached to mutable type variables only. @@ -305,8 +305,8 @@ working. This happens in test case typecheck/should_fail/T5570, for example. See also the commentary on #9404. +-} -\begin{code} -- A TyVarDetails is inside a TyVar data TcTyVarDetails = SkolemTv -- A skolem @@ -394,9 +394,8 @@ data UserTypeCtxt -- f :: <S> => a -> a | DataTyCtxt Name -- Theta part of a data decl -- data <S> => T a = MkT a -\end{code} - +{- -- Notes re TySynCtxt -- We allow type synonyms that aren't types; e.g. type List = [] -- @@ -408,17 +407,17 @@ data UserTypeCtxt -- With gla-exts that's right, but for H98 we should complain. -%************************************************************************ -%* * +************************************************************************ +* * Untoucable type variables -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} newtype TcLevel = TcLevel Int deriving( Eq ) -- See Note [TcLevel and untouchable type variables] for what this Int is -\end{code} +{- Note [TcLevel and untouchable type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Each unification variable (MetaTv) @@ -475,10 +474,10 @@ emerges. If we (wrongly) spontaneously solved it to get uf := beta, the whole implication disappears but when we pop out again we are left with (F Int ~ uf) which will be unified by our final zonking stage and uf will get unified *once more* to (F Int). +-} -\begin{code} fskTcLevel :: TcLevel -fskTcLevel = TcLevel 0 -- 0 = Outside the outermost level: +fskTcLevel = TcLevel 0 -- 0 = Outside the outermost level: -- flatten skolems topTcLevel :: TcLevel @@ -503,16 +502,15 @@ checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) instance Outputable TcLevel where ppr (TcLevel us) = ppr us -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Pretty-printing -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging pprTcTyVarDetails (SkolemTv True) = ptext (sLit "ssk") @@ -564,16 +562,15 @@ pprSigCtxt ctxt extra pp_ty pp_sig _ = pp_ty pp_n_colon n = pprPrefixOcc n <+> dcolon <+> pp_ty -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Finding type family instances -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Finds outermost type-family applications occuring in a type, -- after expanding synonyms. tcTyFamInsts :: Type -> [(TyCon, [Type])] @@ -587,13 +584,13 @@ tcTyFamInsts (LitTy {}) = [] tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 tcTyFamInsts (ForAllTy _ ty) = tcTyFamInsts ty -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * The "exact" free variables of a type -%* * -%************************************************************************ +* * +************************************************************************ Note [Silly type synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -622,8 +619,8 @@ involving Any. So the conclusion is this: when generalising - at top level use tyVarsOfType - in nested bindings use exactTyVarsOfType See Trac #1813 for example. +-} -\begin{code} exactTyVarsOfType :: Type -> TyVarSet -- Find the free type variables (of any kind) -- but *expand* type synonyms. See Note [Silly type synonym] above. @@ -640,15 +637,15 @@ exactTyVarsOfType ty exactTyVarsOfTypes :: [Type] -> TyVarSet exactTyVarsOfTypes = mapUnionVarSet exactTyVarsOfType -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Predicates -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} isTouchableOrFmv :: TcLevel -> TcTyVar -> Bool isTouchableOrFmv ctxt_tclvl tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -684,7 +681,7 @@ isImmutableTyVar tv | otherwise = True isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, - isMetaTyVar, isAmbiguousTyVar, + isMetaTyVar, isAmbiguousTyVar, isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool isTyConableTyVar tv @@ -805,16 +802,15 @@ isRuntimeUnkSkol :: TyVar -> Bool isRuntimeUnkSkol x | isTcTyVar x, RuntimeUnk <- tcTyVarDetails x = True | otherwise = False -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Tau, sigma and rho} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) @@ -837,11 +833,9 @@ mkTcEqPred ty1 ty2 = mkTyConApp eqTyCon [k, ty1, ty2] where k = typeKind ty1 -\end{code} -@isTauTy@ tests for nested for-alls. It should not be called on a boxy type. +-- @isTauTy@ tests for nested for-alls. It should not be called on a boxy type. -\begin{code} isTauTy :: Type -> Bool isTauTy ty | Just ty' <- tcView ty = isTauTy ty' isTauTy (TyVarTy _) = True @@ -871,22 +865,21 @@ getDFunTyKey (ForAllTy _ t) = getDFunTyKey t getDFunTyLitKey :: TyLit -> OccName getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Expanding and splitting} -%* * -%************************************************************************ +* * +************************************************************************ These tcSplit functions are like their non-Tc analogues, but *) they do not look through newtypes However, they are non-monadic and do not follow through mutable type variables. It's up to you to make sure this doesn't matter. +-} -\begin{code} tcSplitForAllTys :: Type -> ([TyVar], Type) tcSplitForAllTys ty = split ty ty [] where @@ -1087,9 +1080,7 @@ tcInstHeadTyAppAllTyVars ty get_tv (TyVarTy tv) = Just tv -- through synonyms get_tv _ = Nothing -\end{code} -\begin{code} tcEqKind :: TcKind -> TcKind -> Bool tcEqKind = tcEqType @@ -1139,8 +1130,8 @@ pickyEqType ty1 ty2 gos _ [] [] = True gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 gos _ _ _ = False -\end{code} +{- Note [Occurs check expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (occurCheckExpand tv xi) expands synonyms in xi just enough to get rid @@ -1164,8 +1155,8 @@ We have even though we could also expand F to get rid of b. See also Note [occurCheckExpand] in TcCanonical +-} -\begin{code} data OccCheckResult a = OC_OK a | OC_Forall @@ -1267,8 +1258,8 @@ canUnifyWithPolyType dflags details kind -- Note [OpenTypeKind accepts foralls] _other -> True -- We can have non-meta tyvars in given constraints -\end{code} +{- Note [OpenTypeKind accepts foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is a common paradigm: @@ -1286,15 +1277,15 @@ we can instantiate it with Int#. So we also allow such type variables to be instantiate with foralls. It's a bit of a hack, but seems straightforward. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Predicate types} -%* * -%************************************************************************ +* * +************************************************************************ Deconstructors and tests on predicate types +-} -\begin{code} isTyVarClassPred :: PredType -> Bool isTyVarClassPred ty = case getClassPredTys_maybe ty of Just (_, tys) -> all isTyVarTy tys @@ -1312,11 +1303,9 @@ evVarPred var Nothing -> pprPanic "tcEvVarPred" (ppr var <+> ppr (varType var)) | otherwise = varType var -\end{code} -Superclasses +-- Superclasses -\begin{code} mkMinimalBySCs :: [PredType] -> [PredType] -- Remove predicates that can be deduced from others by superclasses mkMinimalBySCs ptys = [ ploc | ploc <- ptys @@ -1348,17 +1337,15 @@ immSuperClasses cls tys = substTheta (zipTopTvSubst tyvars tys) sc_theta where (tyvars,sc_theta,_,_) = classBigSig cls -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Predicates} -%* * -%************************************************************************ +* * +************************************************************************ +-} - -\begin{code} isSigmaTy :: TcType -> Bool -- isSigmaTy returns true of any qualified type. It doesn't -- *necessarily* have any foralls. E.g @@ -1381,9 +1368,7 @@ isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty isOverloadedTy (FunTy a _) = isPredTy a isOverloadedTy _ = False -\end{code} -\begin{code} isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, isUnitTy, isCharTy, isAnyTy :: Type -> Bool isFloatTy = is_tc floatTyConKey @@ -1407,15 +1392,15 @@ is_tc :: Unique -> Type -> Bool is_tc uniq ty = case tcSplitTyConApp_maybe ty of Just (tc, _) -> uniq == getUnique tc Nothing -> False -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Misc} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} deNoteType :: Type -> Type -- Remove all *outermost* type synonyms and other notes deNoteType ty | Just ty' <- tcView ty = deNoteType ty' @@ -1435,12 +1420,12 @@ tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar tcTyVarsOfTypes :: [Type] -> TyVarSet tcTyVarsOfTypes = mapUnionVarSet tcTyVarsOfType -\end{code} +{- Find the free tycons and classes of a type. This is used in the front end of the compiler. +-} -\begin{code} orphNamesOfTyCon :: TyCon -> NameSet orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of Nothing -> emptyNameSet @@ -1506,20 +1491,19 @@ orphNamesOfCoAxBranches = brListFoldr (unionNameSet . orphNamesOfCoAxBranch) emp orphNamesOfCoAxBranch :: CoAxBranch -> NameSet orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[TysWiredIn-ext-type]{External types} -%* * -%************************************************************************ +* * +************************************************************************ The compiler's foreign function interface supports the passing of a restricted set of types as arguments and results (the restricting factor being the ) +-} -\begin{code} tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) -- (tcSplitIOType_maybe t) returns Just (IO,t',co) -- if co : t ~ IO t' @@ -1573,7 +1557,7 @@ isFFILabelTy :: Type -> Validity -- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. isFFILabelTy ty = checkRepTyCon ok ty extra where - ok tc = tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey + ok tc = tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey extra = ptext (sLit "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") isFFIPrimArgumentTy :: DynFlags -> Type -> Validity @@ -1612,8 +1596,8 @@ checkRepTyCon check_tc ty extra | otherwise = ptext (sLit "because the data construtor for") <+> quotes (ppr tc) <+> ptext (sLit "is not in scope") nt_fix = ptext (sLit "Possible fix: import the data constructor to bring it into scope") -\end{code} +{- Note [Foreign import dynamic] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign @@ -1632,8 +1616,8 @@ result type 'CInt -> IO ()', and return False, as they are not equal. ---------------------------------------------- These chaps do the work; they are not exported ---------------------------------------------- +-} -\begin{code} legalFEArgTyCon :: TyCon -> Bool legalFEArgTyCon tc -- It's illegal to make foreign exports that take unboxed @@ -1715,8 +1699,8 @@ legalFIPrimResultTyCon dflags tc = True | otherwise = False -\end{code} +{- Note [Marshalling VoidRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't treat State# (whose PrimRep is VoidRep) as marshalable. @@ -1725,3 +1709,4 @@ In turn that means you can't write Reason: the back end falls over with panic "primRepHint:VoidRep"; and there is no compelling reason to permit it +-} diff --git a/compiler/typecheck/TcType.lhs-boot b/compiler/typecheck/TcType.hs-boot index 15c23676bc..656c4242ce 100644 --- a/compiler/typecheck/TcType.lhs-boot +++ b/compiler/typecheck/TcType.hs-boot @@ -1,9 +1,7 @@ -\begin{code} module TcType where import Outputable( SDoc ) data MetaDetails -data TcTyVarDetails +data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc -\end{code} diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.hs index 4936d59fa0..b75f0e85a7 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Type subsumption and unification +-} -\begin{code} {-# LANGUAGE CPP #-} module TcUnify ( @@ -57,14 +57,13 @@ import Outputable import FastString import Control.Monad -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * matchExpected functions -%* * -%************************************************************************ +* * +************************************************************************ Note [Herald for matchExpectedFunTys] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -103,9 +102,8 @@ namely: This is not (currently) where deep skolemisation occurs; matchExpectedFunTys does not skolmise nested foralls in the expected type, because it expects that to have been done already +-} - -\begin{code} matchExpectedFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys] -> Arity -> TcRhoType @@ -172,8 +170,8 @@ matchExpectedFunTys herald arity orig_ty sep [ptext (sLit "but its type") <+> quotes (pprType ty), if n_args == 0 then ptext (sLit "has none") else ptext (sLit "has only") <+> speakN n_args] -\end{code} +{- Note [Foralls to left of arrow] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -182,8 +180,8 @@ We give 'f' the type (alpha -> beta), and then want to unify the alpha with (forall a. a->a). We want to the arg and result of (->) to have openTypeKind, and this also permits foralls, so we are ok. +-} -\begin{code} ---------------------- matchExpectedListTy :: TcRhoType -> TcM (TcCoercion, TcRhoType) -- Special case for lists @@ -288,14 +286,13 @@ matchExpectedAppTy orig_ty -- try compiling f x = do { x } -- and you'll get a kind mis-match. It smells, but -- not enough to lose sleep over. -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Subsumption checking -%* * -%************************************************************************ +* * +************************************************************************ Note [Subsumption checking: tcSubType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -361,9 +358,8 @@ The following happens: So it's important that we unify beta := forall a. a->a, rather than skolemising the type. +-} - -\begin{code} tcSubType :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper -- Checks that actual <= expected -- Returns HsWrapper :: actual ~ expected @@ -491,16 +487,15 @@ tcInfer tc_check ; writeMetaTyVar ret_tv tau_ty ; return tau_ty } ; return (res, res_ty) } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Generalisation} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tcGen :: UserTypeCtxt -> TcType -> ([TcTyVar] -> TcRhoType -> TcM result) -> TcM (HsWrapper, result) @@ -587,18 +582,18 @@ newImplication skol_info skol_tvs given thing_inside , ic_info = skol_info } ; return (TcEvBinds ev_binds_var, result) } } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Boxy unification -%* * -%************************************************************************ +* * +************************************************************************ The exported functions are all defined as versions of some non-exported generic functions. +-} -\begin{code} unifyType :: TcTauType -> TcTauType -> TcM TcCoercion -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 @@ -619,33 +614,33 @@ unifyTheta theta1 theta2 (vcat [ptext (sLit "Contexts differ in length"), nest 2 $ parens $ ptext (sLit "Use RelaxedPolyRec to allow this")]) ; zipWithM unifyPred theta1 theta2 } -\end{code} +{- @unifyTypeList@ takes a single list of @TauType@s and unifies them all together. It is used, for example, when typechecking explicit lists, when all the elts should be of the same type. +-} -\begin{code} unifyTypeList :: [TcTauType] -> TcM () unifyTypeList [] = return () unifyTypeList [_] = return () unifyTypeList (ty1:tys@(ty2:_)) = do { _ <- unifyType ty1 ty2 ; unifyTypeList tys } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * uType and friends -%* * -%************************************************************************ +* * +************************************************************************ uType is the heart of the unifier. Each arg occurs twice, because we want to report errors in terms of synomyms if possible. The first of the pair is used in error messages only; it is always the same as the second, except that if the first is a synonym then the second may be a de-synonym'd version. This way we get better error messages. +-} -\begin{code} ------------ uType, uType_defer :: CtOrigin @@ -768,8 +763,8 @@ uType origin orig_ty1 orig_ty2 = do { co_s <- uType origin s1 s2 -- See Note [Unifying AppTy] ; co_t <- uType origin t1 t2 ; return $ mkTcAppCo co_s co_t } -\end{code} +{- Note [Care with type applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note: type applications need a bit of care! @@ -843,18 +838,18 @@ synonyms have already been expanded via tcCoreView). This is, as usual, to improve error messages. -%************************************************************************ -%* * +************************************************************************ +* * uVar and friends -%* * -%************************************************************************ +* * +************************************************************************ @uVar@ is called when at least one of the types being unified is a variable. It does {\em not} assume that the variable is a fixed point of the substitution; rather, notice that @uVar@ (defined below) nips back into @uTys@ if it turns out that the variable is already bound. +-} -\begin{code} uUnfilledVar :: CtOrigin -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 @@ -1002,8 +997,8 @@ checkTauTvUpdate dflags tv ty defer_me (FunTy arg res) = defer_me arg || defer_me res defer_me (AppTy fun arg) = defer_me fun || defer_me arg defer_me (ForAllTy _ ty) = not impredicative || defer_me ty -\end{code} +{- Note [Conservative unification check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When unifying (tv ~ rhs), w try to avoid creating deferred constraints @@ -1097,8 +1092,8 @@ use a local "ok" function, a variant of TcType.occurCheckExpand. HOWEVER, we *do* now have a flat-cache, which effectively recovers the sharing, so there's no great harm in losing it -- and it's generally more efficient to do the unification up-front. +-} -\begin{code} data LookupTyVarResult -- The result of a lookupTcTyVar call = Unfilled TcTyVarDetails -- SkolemTv or virgin MetaTv | Filled TcType @@ -1125,8 +1120,8 @@ updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM TcCoercion updateMeta tv1 ref1 ty2 = do { writeMetaTyVarRef tv1 ref1 ty2 ; return (mkTcNomReflCo ty2) } -\end{code} +{- Note [Unifying untouchables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We treat an untouchable type variable as if it was a skolem. That @@ -1134,11 +1129,11 @@ ensures it won't unify with anything. It's a slight had, because we return a made-up TcTyVarDetails, but I think it works smoothly. -%************************************************************************ -%* * +************************************************************************ +* * Kind unification -%* * -%************************************************************************ +* * +************************************************************************ Unifying kinds is much, much simpler than unifying types. @@ -1173,9 +1168,8 @@ scope. So at least during kind unification we can encounter a KindVar. Hence the isTcTyVar tests before calling lookupTcTyVar. +-} - -\begin{code} matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind)) -- Like unifyFunTy, but does not fail; instead just returns Nothing @@ -1306,4 +1300,3 @@ unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s) else Nothing) } unifyKindEq _ _ = return Nothing -\end{code} diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.hs-boot index 35a7155a08..2acecd6d74 100644 --- a/compiler/typecheck/TcUnify.lhs-boot +++ b/compiler/typecheck/TcUnify.hs-boot @@ -1,4 +1,3 @@ -\begin{code} module TcUnify where import TcType ( TcTauType ) import TcRnTypes ( TcM ) @@ -8,4 +7,3 @@ import TcEvidence ( TcCoercion ) -- TcUnify and Inst unifyType :: TcTauType -> TcTauType -> TcM TcCoercion -\end{code} diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.hs index e1f4293d96..0f3314723b 100644 --- a/compiler/typecheck/TcValidity.lhs +++ b/compiler/typecheck/TcValidity.hs @@ -1,17 +1,16 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} -\begin{code} {-# LANGUAGE CPP #-} module TcValidity ( Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, - expectedKindInCtxt, + expectedKindInCtxt, checkValidTheta, checkValidFamPats, checkValidInstance, validDerivPred, - checkInstTermination, checkValidTyFamInst, checkTyFamFreeness, + checkInstTermination, checkValidTyFamInst, checkTyFamFreeness, checkConsistentFamInst, arityErr, badATErr ) where @@ -50,17 +49,15 @@ import FastString import Control.Monad import Data.Maybe import Data.List ( (\\) ) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Checking for ambiguity -%* * -%************************************************************************ +* * +************************************************************************ +-} - -\begin{code} checkAmbiguity :: UserTypeCtxt -> Type -> TcM () checkAmbiguity ctxt ty | GhciCtxt <- ctxt -- Allow ambiguous types in GHCi's :kind command @@ -69,7 +66,7 @@ checkAmbiguity ctxt ty -- (T k) is ambiguous! | InfSigCtxt {} <- ctxt -- See Note [Validity of inferred types] in TcBinds - = return () + = return () | otherwise = do { traceTc "Ambiguity check for" (ppr ty) @@ -101,24 +98,23 @@ checkAmbiguity ctxt ty where mk_msg ty = pprSigCtxt ctxt (ptext (sLit "the ambiguity check for")) (ppr ty) ambig_msg = ptext (sLit "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes") -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Checking validity of a user-defined type -%* * -%************************************************************************ +* * +************************************************************************ When dealing with a user-written type, we first translate it from an HsType -to a Type, performing kind checking, and then check various things that should +to a Type, performing kind checking, and then check various things that should be true about it. We don't want to perform these checks at the same time as the initial translation because (a) they are unnecessary for interface-file types and (b) when checking a mutually recursive group of type and class decls, we can't "look" at the tycons/classes yet. Also, the checks are are rather diverse, and used to really mess up the other code. -One thing we check for is 'rank'. +One thing we check for is 'rank'. Rank 0: monotypes (no foralls) Rank 1: foralls at the front only, Rank 0 inside @@ -130,19 +126,18 @@ One thing we check for is 'rank'. r2a ::= r1 -> r2a | basic r1 ::= forall tvs. cxt => r0 r0 ::= r0 -> r0 | basic - -Another thing is to check that type synonyms are saturated. + +Another thing is to check that type synonyms are saturated. This might not necessarily show up in kind checking. type A i = i data T k = MkT (k Int) f :: T A -- BAD! +-} - -\begin{code} checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context -- Not used for instance decls; checkValidInstance instead -checkValidType ctxt ty +checkValidType ctxt ty = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) ; rankn_flag <- xoptM Opt_RankNTypes ; let gen_rank :: Rank -> Rank @@ -220,17 +215,17 @@ expectedKindInCtxt (ForSigCtxt _) = Just liftedTypeKind expectedKindInCtxt InstDeclCtxt = Just constraintKind expectedKindInCtxt SpecInstCtxt = Just constraintKind expectedKindInCtxt _ = Just openTypeKind -\end{code} +{- Note [Higher rank types] ~~~~~~~~~~~~~~~~~~~~~~~~ -Technically +Technically Int -> forall a. a->a is still a rank-1 type, but it's not Haskell 98 (Trac #5957). So the validity checker allow a forall after an arrow only if we allow it before -- that is, with Rank2Types or RankNTypes +-} -\begin{code} data Rank = ArbitraryRank -- Any rank ok | LimitedRank -- Note [Higher rank types] @@ -238,7 +233,7 @@ data Rank = ArbitraryRank -- Any rank ok Rank -- Use for function arguments | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype - + | MustBeMonoType -- Monotype regardless of flags rankZeroMonoType, tyConArgMonoType, synArgMonoType :: Rank @@ -268,21 +263,21 @@ check_mono_type ctxt rank ty check_type :: UserTypeCtxt -> Rank -> Type -> TcM () -- The args say what the *type context* requires, independent -- of *flag* settings. You test the flag settings at usage sites. --- +-- -- Rank is allowed rank for function args -- Rank 0 means no for-alls anywhere check_type ctxt rank ty | not (null tvs && null theta) = do { checkTc (forAllAllowed rank) (forAllTyErr rank ty) - -- Reject e.g. (Maybe (?x::Int => Int)), + -- Reject e.g. (Maybe (?x::Int => Int)), -- with a decent error message ; check_valid_theta ctxt theta ; check_type ctxt rank tau -- Allow foralls to right of arrow ; checkAmbiguity ctxt ty } where (tvs, theta, tau) = tcSplitSigmaTy ty - + check_type _ _ (TyVarTy _) = return () check_type ctxt rank (FunTy arg_ty res_ty) @@ -309,7 +304,7 @@ check_type _ _ ty = pprPanic "check_type" (ppr ty) check_syn_tc_app :: UserTypeCtxt -> Rank -> KindOrType -> TyCon -> [KindOrType] -> TcM () -- Used for type synonyms and type synonym families, --- which must be saturated, +-- which must be saturated, -- but not data families, which need not be saturated check_syn_tc_app ctxt rank ty tc tys | tc_arity <= n_args -- Saturated @@ -326,11 +321,11 @@ check_syn_tc_app ctxt rank ty tc tys mapM_ check_arg tys else -- In the liberal case (only for closed syns), expand then check - case tcView ty of - Just ty' -> check_type ctxt rank ty' + case tcView ty of + Just ty' -> check_type ctxt rank ty' Nothing -> pprPanic "check_tau_type" (ppr ty) } - | GhciCtxt <- ctxt -- Accept under-saturated type synonyms in + | GhciCtxt <- ctxt -- Accept under-saturated type synonyms in -- GHCi :kind commands; see Trac #7586 = mapM_ check_arg tys @@ -343,21 +338,21 @@ check_syn_tc_app ctxt rank ty tc tys tc_arity = tyConArity tc check_arg | isTypeFamilyTyCon tc = check_arg_type ctxt rank | otherwise = check_mono_type ctxt synArgMonoType - + ---------------------------------------- -check_ubx_tuple :: UserTypeCtxt -> KindOrType +check_ubx_tuple :: UserTypeCtxt -> KindOrType -> [KindOrType] -> TcM () check_ubx_tuple ctxt ty tys = do { ub_tuples_allowed <- xoptM Opt_UnboxedTuples ; checkTc ub_tuples_allowed (ubxArgTyErr ty) - ; impred <- xoptM Opt_ImpredicativeTypes + ; impred <- xoptM Opt_ImpredicativeTypes ; let rank' = if impred then ArbitraryRank else tyConArgMonoType -- c.f. check_arg_type -- However, args are allowed to be unlifted, or -- more unboxed tuples, so can't use check_arg_ty ; mapM_ (check_type ctxt rank') tys } - + ---------------------------------------- check_arg_type :: UserTypeCtxt -> Rank -> KindOrType -> TcM () -- The sort of type that can instantiate a type variable, @@ -365,7 +360,7 @@ check_arg_type :: UserTypeCtxt -> Rank -> KindOrType -> TcM () -- Not an unboxed tuple, but now *can* be a forall (since impredicativity) -- Other unboxed types are very occasionally allowed as type -- arguments depending on the kind of the type constructor --- +-- -- For example, we want to reject things like: -- -- instance Ord a => Ord (forall s. T s a) @@ -386,21 +381,21 @@ check_arg_type ctxt rank ty MustBeMonoType -> MustBeMonoType -- Monotype, regardless _other | impred -> ArbitraryRank | otherwise -> tyConArgMonoType - -- Make sure that MustBeMonoType is propagated, + -- Make sure that MustBeMonoType is propagated, -- so that we don't suggest -XImpredicativeTypes in -- (Ord (forall a.a)) => a -> a -- and so that if it Must be a monotype, we check that it is! ; check_type ctxt rank' ty ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } - -- NB the isUnLiftedType test also checks for + -- NB the isUnLiftedType test also checks for -- T State# -- where there is an illegal partial application of State# (which has -- kind * -> #); see Note [The kind invariant] in TypeRep ---------------------------------------- forAllTyErr :: Rank -> Type -> SDoc -forAllTyErr rank ty +forAllTyErr rank ty = vcat [ hang (ptext (sLit "Illegal polymorphic or qualified type:")) 2 (ppr ty) , suggestion ] where @@ -415,8 +410,8 @@ ubxArgTyErr ty = sep [ptext (sLit "Illegal unboxed tuple type as function ar kindErr :: Kind -> SDoc kindErr kind = sep [ptext (sLit "Expecting an ordinary type, but found a type of kind"), ppr kind] -\end{code} +{- Note [Liberal type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If -XLiberalTypeSynonyms is on, expand closed type synonyms *before* @@ -446,11 +441,11 @@ If we do both, we get exponential behaviour!! type TIACons7 t x = TIACons4 t (TIACons3 t x) -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Checking a theta or source type} -%* * -%************************************************************************ +* * +************************************************************************ Note [Implicit parameters in instance decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -463,8 +458,8 @@ then when we saw it would be unclear how to discharge all the potential uses of the ?x in e. For example, a constraint Foo [Int] might come out of e, and applying the instance decl would show up two uses of ?x. Trac #8912. +-} -\begin{code} checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () checkValidTheta ctxt theta = addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta) @@ -601,7 +596,7 @@ check_class_pred_tys dflags ctxt kts ------------------------- tyvar_head :: Type -> Bool -tyvar_head ty -- Haskell 98 allows predicates of form +tyvar_head ty -- Haskell 98 allows predicates of form | tcIsTyVarTy ty = True -- C (a ty1 .. tyn) | otherwise -- where a is a type variable = case tcSplitAppTy_maybe ty of @@ -618,8 +613,8 @@ okIPCtxt _ = True badIPPred :: PredType -> SDoc badIPPred pred = ptext (sLit "Illegal implicit parameter") <+> quotes (ppr pred) -\end{code} +{- Note [Kind polymorphic type classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ MultiParam check: @@ -648,12 +643,12 @@ example we want to reject: The idea is there can be no legal calls to 'f' because every call will give rise to an ambiguous constraint. We could soundly omit the ambiguity check on type signatures entirely, at the expense of -delaying ambiguity errors to call sites. Indeed, the flag +delaying ambiguity errors to call sites. Indeed, the flag -XAllowAmbiguousTypes switches off the ambiguity check. What about things like this: class D a b | a -> b where .. - h :: D Int b => Int + h :: D Int b => Int The Int may well fix 'b' at the call site, so that signature should not be rejected. Moreover, using *visible* fundeps is too conservative. Consider @@ -667,7 +662,7 @@ That gives rise to a (X [Bool] beta) constraint, and using the instance means we need (D Bool beta) and that fixes 'beta' via D's fundep! -Behind all these special cases there is a simple guiding principle. +Behind all these special cases there is a simple guiding principle. Consider f :: <type> @@ -682,7 +677,7 @@ is instantiated and the instantiated constraints are solved against the originals, so in the case an ambiguous type it won't work. Consider our earlier example f :: C a => Int. Then in g's definition, we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a), -and fail. +and fail. So in fact we use this as our *definition* of ambiguity. We use a very similar test for *inferred* types, to ensure that they are @@ -690,7 +685,7 @@ unambiguous. See Note [Impedence matching] in TcBinds. This test is very conveniently implemented by calling tcSubType <type> <type> -This neatly takes account of the functional dependecy stuff above, +This neatly takes account of the functional dependecy stuff above, and implicit parameter (see Note [Implicit parameters and ambiguity]). What about this, though? @@ -698,7 +693,7 @@ What about this, though? Is every call to 'g' ambiguous? After all, we might have intance C [a] where ... at the call site. So maybe that type is ok! Indeed even f's -quintessentially ambiguous type might, just possibly be callable: +quintessentially ambiguous type might, just possibly be callable: with -XFlexibleInstances we could have instance C a where ... and now a call could be legal after all! Well, we'll reject this @@ -717,7 +712,7 @@ ambiguous types. Example Here the worker for f gets the type fw :: forall a. S a => Int -> (# Int, Int #) -Note [Implicit parameters and ambiguity] +Note [Implicit parameters and ambiguity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Only a *class* predicate can give rise to ambiguity An *implicit parameter* cannot. For example: @@ -735,7 +730,8 @@ we might have and all is well. In effect, implicit parameters are, well, parameters, so we can take their type variables into account as part of the "tau-tvs" stuff. This is done in the function 'FunDeps.grow'. -\begin{code} +-} + checkThetaCtxt :: UserTypeCtxt -> ThetaType -> SDoc checkThetaCtxt ctxt theta = vcat [ptext (sLit "In the context:") <+> pprTheta theta, @@ -752,7 +748,7 @@ predTupleErr pred = hang (ptext (sLit "Illegal tuple constraint:") <+> pprType predIrredErr pred = hang (ptext (sLit "Illegal constraint:") <+> pprType pred) 2 (parens constraintKindsMsg) predIrredBadCtxtErr pred = hang (ptext (sLit "Illegal constraint") <+> quotes (pprType pred) - <+> ptext (sLit "in a superclass/instance context")) + <+> ptext (sLit "in a superclass/instance context")) 2 (parens undecidableMsg) constraintSynErr :: Type -> SDoc @@ -765,19 +761,19 @@ dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas p arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc arityErr kind name n m = hsep [ text kind, quotes (ppr name), ptext (sLit "should have"), - n_arguments <> comma, text "but has been given", + n_arguments <> comma, text "but has been given", if m==0 then text "none" else int m] where n_arguments | n == 0 = ptext (sLit "no arguments") | n == 1 = ptext (sLit "1 argument") | True = hsep [int n, ptext (sLit "arguments")] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Checking for a decent instance head type} -%* * -%************************************************************************ +* * +************************************************************************ @checkValidInstHead@ checks the type {\em and} its syntactic constraints: it must normally look like: @instance Foo (Tycon a b c ...) ...@ @@ -787,8 +783,8 @@ flag is on, or (2)~the instance is imported (they must have been compiled elsewhere). In these cases, we let them go through anyway. We can also have instances for functions: @instance Foo (a -> b) ...@. +-} -\begin{code} checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () checkValidInstHead ctxt clas cls_args = do { dflags <- getDynFlags @@ -796,7 +792,7 @@ checkValidInstHead ctxt clas cls_args ; checkTc (clas `notElem` abstractClasses) (instTypeErr clas cls_args abstract_class_msg) - -- Check language restrictions; + -- Check language restrictions; -- but not for SPECIALISE isntance pragmas ; let ty_args = dropWhile isKind cls_args ; unless spec_inst_prag $ @@ -816,8 +812,8 @@ checkValidInstHead ctxt clas cls_args ; mapM_ checkTyFamFreeness ty_args ; mapM_ checkValidMonoType ty_args - -- For now, I only allow tau-types (not polytypes) in - -- the head of an instance decl. + -- For now, I only allow tau-types (not polytypes) in + -- the head of an instance decl. -- E.g. instance C (forall a. a->a) is rejected -- One could imagine generalising that, but I'm not sure -- what all the consequences might be @@ -852,41 +848,40 @@ instTypeErr cls tys msg = hang (hang (ptext (sLit "Illegal instance declaration for")) 2 (quotes (pprClassPred cls tys))) 2 msg -\end{code} +{- validDeivPred checks for OK 'deriving' context. See Note [Exotic derived instance contexts] in TcSimplify. However the predicate is here because it uses sizeTypes, fvTypes. -Also check for a bizarre corner case, when the derived instance decl +Also check for a bizarre corner case, when the derived instance decl would look like instance C a b => D (T a) where ... Note that 'b' isn't a parameter of T. This gives rise to all sorts of problems; in particular, it's hard to compare solutions for equality when finding the fixpoint, and that means the inferContext loop does not converge. See Trac #5287. +-} -\begin{code} validDerivPred :: TyVarSet -> PredType -> Bool validDerivPred tv_set pred = case classifyPredType pred of - ClassPred _ tys -> hasNoDups fvs + ClassPred _ tys -> hasNoDups fvs && sizeTypes tys == length fvs && all (`elemVarSet` tv_set) fvs TuplePred ps -> all (validDerivPred tv_set) ps _ -> True -- Non-class predicates are ok where fvs = fvType pred -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Checking instance for termination} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} checkValidInstance :: UserTypeCtxt -> LHsType Name -> Type -> TcM ([TyVar], ThetaType, Class, [Type]) checkValidInstance ctxt hs_type ty @@ -899,24 +894,24 @@ checkValidInstance ctxt hs_type ty -- Check that instance inference will terminate (if we care) -- For Haskell 98 this will already have been done by checkValidTheta, -- but as we may be using other extensions we need to check. - -- - -- Note that the Termination Condition is *more conservative* than + -- + -- Note that the Termination Condition is *more conservative* than -- the checkAmbiguity test we do on other type signatures -- e.g. Bar a => Bar Int is ambiguous, but it also fails -- the termination condition, because 'a' appears more often -- in the constraint than in the head ; undecidable_ok <- xoptM Opt_UndecidableInstances - ; if undecidable_ok + ; if undecidable_ok then checkAmbiguity ctxt ty else checkInstTermination inst_tys theta ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of IsValid -> return () -- Check succeeded NotValid msg -> addErrTc (instTypeErr clas inst_tys msg) - - ; return (tvs, theta, clas, inst_tys) } - | otherwise + ; return (tvs, theta, clas, inst_tys) } + + | otherwise = failWithTc (ptext (sLit "Malformed instance head:") <+> ppr tau) where (tvs, theta, tau) = tcSplitSigmaTy ty @@ -925,12 +920,12 @@ checkValidInstance ctxt hs_type ty head_loc = case hs_type of L _ (HsForAllTy _ _ _ _ (L loc _)) -> loc L loc _ -> loc -\end{code} +{- Note [Paterson conditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Termination test: the so-called "Paterson conditions" (see Section 5 of -"Understanding functionsl dependencies via Constraint Handling Rules, +"Understanding functionsl dependencies via Constraint Handling Rules, JFP Jan 2007). We check that each assertion in the context satisfies: @@ -938,15 +933,14 @@ We check that each assertion in the context satisfies: (2) the assertion has fewer constructors and variables (taken together and counting repetitions) than the head. This is only needed with -fglasgow-exts, as Haskell 98 restrictions -(which have already been checked) guarantee termination. +(which have already been checked) guarantee termination. -The underlying idea is that +The underlying idea is that for any ground substitution, each assertion in the context has fewer type constructors than the head. +-} - -\begin{code} checkInstTermination :: [TcType] -> ThetaType -> TcM () -- See Note [Paterson conditions] checkInstTermination tys theta @@ -959,7 +953,7 @@ checkInstTermination tys theta check_preds preds = mapM_ check preds check :: PredType -> TcM () - check pred + check pred = case classifyPredType pred of TuplePred preds -> check_preds preds -- Look inside tuple predicates; Trac #8359 EqPred {} -> return () -- You can't get from equalities @@ -982,8 +976,8 @@ predUndecErr pred msg = sep [msg, nest 2 (ptext (sLit "in the constraint:") <+> pprType pred)] nomoreMsg :: [TcTyVar] -> SDoc -nomoreMsg tvs - = sep [ ptext (sLit "Variable") <> plural tvs <+> quotes (pprWithCommas ppr tvs) +nomoreMsg tvs + = sep [ ptext (sLit "Variable") <> plural tvs <+> quotes (pprWithCommas ppr tvs) , (if isSingleton tvs then ptext (sLit "occurs") else ptext (sLit "occur")) <+> ptext (sLit "more often than in the instance head") ] @@ -992,10 +986,8 @@ smallerMsg, undecidableMsg, constraintKindsMsg :: SDoc smallerMsg = ptext (sLit "Constraint is no smaller than the instance head") undecidableMsg = ptext (sLit "Use UndecidableInstances to permit this") constraintKindsMsg = ptext (sLit "Use ConstraintKinds to permit this") -\end{code} - - +{- Note [Associated type instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We allow this: @@ -1005,7 +997,7 @@ We allow this: type T (S y) Int = y type T Z Int = Char -Note that +Note that a) The variable 'x' is not bound by the class decl b) 'x' is instantiated to a non-type-variable in the instance c) There are several type instance decls for T in the instance @@ -1022,7 +1014,7 @@ Note [Checking consistent instantiation] type T [p] y Int = (p,y,y) -- Induces the family instance TyCon -- type TR p y = (p,y,y) -So we +So we * Form the mini-envt from the class type variables a,b to the instance decl types [p],Int: [a->[p], b->Int] @@ -1032,7 +1024,7 @@ So we * Apply the mini-evnt to them, and check that the result is consistent with the instance types [p] y Int -We do *not* assume (at this point) the the bound variables of +We do *not* assume (at this point) the the bound variables of the assoicated type instance decl are the same as for the parent instance decl. So, for example, @@ -1064,9 +1056,9 @@ Here the instance is kind-indexed and really looks like type F (k->k) (b::k->k) = Int But if the 'b' didn't scope, we would make F's instance too poly-kinded. +-} -\begin{code} -checkConsistentFamInst +checkConsistentFamInst :: Maybe ( Class , VarEnv Type ) -- ^ Class of associated type -- and instantiation of class TyVars @@ -1103,7 +1095,7 @@ checkConsistentFamInst (Just (clas, mini_env)) fam_tc at_tvs at_tys -- See Note [Associated type instances] all_distinct :: TvSubst -> Bool - -- True if all the variables mapped the substitution + -- True if all the variables mapped the substitution -- map to *distinct* type *variables* all_distinct subst = go [] at_tvs where @@ -1117,7 +1109,7 @@ checkConsistentFamInst (Just (clas, mini_env)) fam_tc at_tvs at_tys badATErr :: Name -> Name -> SDoc badATErr clas op - = hsep [ptext (sLit "Class"), quotes (ppr clas), + = hsep [ptext (sLit "Class"), quotes (ppr clas), ptext (sLit "does not have an associated type"), quotes (ppr op)] wrongATArgErr :: Type -> Type -> SDoc @@ -1126,25 +1118,24 @@ wrongATArgErr ty instTy = , ptext (sLit "Found") <+> quotes (ppr ty) <+> ptext (sLit "but expected") <+> quotes (ppr instTy) ] -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Checking type instance well-formedness and termination -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- Check that a "type instance" is well-formed (which includes decidability -- unless -XUndecidableInstances is given). -- checkValidTyFamInst :: Maybe ( Class, VarEnv Type ) -> TyCon -> CoAxBranch -> TcM () -checkValidTyFamInst mb_clsinfo fam_tc +checkValidTyFamInst mb_clsinfo fam_tc (CoAxBranch { cab_tvs = tvs, cab_lhs = typats , cab_rhs = rhs, cab_loc = loc }) - = setSrcSpan loc $ + = setSrcSpan loc $ do { checkValidFamPats fam_tc tvs typats -- The argument patterns, and RHS, are all boxed tau types @@ -1165,7 +1156,7 @@ checkValidTyFamInst mb_clsinfo fam_tc -- Check that type patterns match the class instance head ; checkConsistentFamInst mb_clsinfo fam_tc tvs typats } --- Make sure that each type family application is +-- Make sure that each type family application is -- (1) strictly smaller than the lhs, -- (2) mentions no type variable more often than the lhs, and -- (3) does not contain any further type family instances. @@ -1230,14 +1221,14 @@ isTyFamFree = null . tcTyFamInsts tyFamInstIllegalErr :: Type -> SDoc tyFamInstIllegalErr ty - = hang (ptext (sLit "Illegal type synonym family application in instance") <> + = hang (ptext (sLit "Illegal type synonym family application in instance") <> colon) 2 $ ppr ty famInstUndecErr :: Type -> SDoc -> SDoc -famInstUndecErr ty msg - = sep [msg, - nest 2 (ptext (sLit "in the type family application:") <+> +famInstUndecErr ty msg + = sep [msg, + nest 2 (ptext (sLit "in the type family application:") <+> pprType ty)] famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc @@ -1250,15 +1241,15 @@ famPatErr fam_tc tvs pats nestedMsg, smallerAppMsg :: SDoc nestedMsg = ptext (sLit "Nested type family application") smallerAppMsg = ptext (sLit "Application is no smaller than the instance head") -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Auxiliary functions} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- Free variables of a type, retaining repetitions, and expanding synonyms fvType :: Type -> [TyVar] fvType ty | Just exp_ty <- tcView ty = fvType exp_ty @@ -1306,8 +1297,8 @@ sizePred ty = goClass ty go (EqPred {}) = 0 go (TuplePred ts) = sum (map goClass ts) go (IrredPred ty) = sizeType ty -\end{code} +{- Note [Paterson conditions on PredTypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We are considering whether *class* constraints terminate @@ -1331,6 +1322,7 @@ this actually is. There are two main tricks: can't get back to a class constraint, so it's safe to say "size 0". See Trac #4200. -NB: we don't want to detect PredTypes in sizeType (and then call +NB: we don't want to detect PredTypes in sizeType (and then call sizePred on them), or we might get an infinite loop if that PredType is irreducible. See Trac #5581. +-} |