diff options
195 files changed, 5807 insertions, 4558 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 2f86db7796..4fbfb6007a 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -155,9 +155,11 @@ type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). -- This information may be useful in optimisation, as computations may -- safely be floated inside such a lambda without risk of duplicating -- work. -data OneShotInfo = NoOneShotInfo -- ^ No information - | ProbOneShot -- ^ The lambda is probably applied at most once - | OneShotLam -- ^ The lambda is applied at most once. +data OneShotInfo + = NoOneShotInfo -- ^ No information + | ProbOneShot -- ^ The lambda is probably applied at most once + -- See Note [Computing one-shot info, and ProbOneShot] in OccurAnl + | OneShotLam -- ^ The lambda is applied at most once. -- | It is always safe to assume that an 'Id' has no lambda-bound variable information noOneShotInfo :: OneShotInfo diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index 2aa25ced53..f553fc2ae5 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -1493,6 +1493,11 @@ newtype StrictSig = StrictSig DmdType instance Outputable StrictSig where ppr (StrictSig ty) = ppr ty +-- Used for printing top-level strictness pragmas in interface files +pprIfaceStrictSig :: StrictSig -> SDoc +pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) + = hcat (map ppr dmds) <> ppr res + mkStrictSig :: DmdType -> StrictSig mkStrictSig dmd_ty = StrictSig dmd_ty @@ -1520,29 +1525,8 @@ botSig = StrictSig botDmdType cprProdSig :: Arity -> StrictSig cprProdSig arity = StrictSig (cprProdDmdType arity) -argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] -argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args - = go arg_ds - where - good_one_shot - | arg_ds `lengthExceeds` n_val_args = ProbOneShot - | otherwise = OneShotLam - - go [] = [] - go (arg_d : arg_ds) = argOneShots good_one_shot arg_d `cons` go arg_ds - - cons [] [] = [] - cons a as = a:as - -argOneShots :: OneShotInfo -> JointDmd -> [OneShotInfo] -argOneShots one_shot_info (JD { absd = usg }) - = case usg of - Use _ arg_usg -> go arg_usg - _ -> [] - where - go (UCall One u) = one_shot_info : go u - go (UCall Many u) = NoOneShotInfo : go u - go _ = [] +seqStrictSig :: StrictSig -> () +seqStrictSig (StrictSig ty) = seqDmdType ty dmdTransformSig :: StrictSig -> CleanDemand -> DmdType -- (dmdTransformSig fun_sig dmd) considers a call to a function whose @@ -1617,31 +1601,79 @@ you might do strictness analysis, but there is no inlining for the class op. This is weird, so I'm not worried about whether this optimises brilliantly; but it should not fall over. -Note [Non-full application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a function having bottom as its demand result is applied to a less -number of arguments than its syntactic arity, we cannot say for sure -that it is going to diverge. This is the reason why we use the -function appIsBottom, which, given a strictness signature and a number -of arguments, says conservatively if the function is going to diverge -or not. +\begin{code} +argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] +-- See Note [Computing one-shot info, and ProbOneShot] +argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args + = go arg_ds + where + unsaturated_call = arg_ds `lengthExceeds` n_val_args + good_one_shot + | unsaturated_call = ProbOneShot + | otherwise = OneShotLam + + go [] = [] + go (arg_d : arg_ds) = argOneShots good_one_shot arg_d `cons` go arg_ds + + -- Avoid list tail like [ [], [], [] ] + cons [] [] = [] + cons a as = a:as + +argOneShots :: OneShotInfo -> JointDmd -> [OneShotInfo] +argOneShots one_shot_info (JD { absd = usg }) + = case usg of + Use _ arg_usg -> go arg_usg + _ -> [] + where + go (UCall One u) = one_shot_info : go u + go (UCall Many u) = NoOneShotInfo : go u + go _ = [] +\end{code} + +Note [Computing one-shot info, and ProbOneShot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a call + f (\pqr. e1) (\xyz. e2) e3 +where f has usage signature + C1(C(C1(U))) C1(U) U +Then argsOneShots returns a [[OneShotInfo]] of + [[OneShot,NoOneShotInfo,OneShot], [OneShot]] +The occurrence analyser propagates this one-shot infor to the +binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. + +But suppose f was not saturated, so the call looks like + f (\pqr. e1) (\xyz. e2) +The in principle this partial application might be shared, and +the (\prq.e1) abstraction might be called more than once. So +we can't mark them OneShot. But instead we return + [[ProbOneShot,NoOneShotInfo,ProbOneShot], [ProbOneShot]] +The occurrence analyser propagates this to the \pqr and \xyz +binders. + +How is it used? Well, it's quite likely that the partial application +of f is not shared, so the float-out pass (in SetLevels.lvlLamBndrs) +does not float MFEs out of a ProbOneShot lambda. That currently is +the only way that ProbOneShot is used. + \begin{code} -- appIsBottom returns true if an application to n args would diverge +-- See Note [Unsaturated applications] appIsBottom :: StrictSig -> Int -> Bool appIsBottom (StrictSig (DmdType _ ds res)) n | isBotRes res = not $ lengthExceeds ds n appIsBottom _ _ = False - -seqStrictSig :: StrictSig -> () -seqStrictSig (StrictSig ty) = seqDmdType ty - --- Used for printing top-level strictness pragmas in interface files -pprIfaceStrictSig :: StrictSig -> SDoc -pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) - = hcat (map ppr dmds) <> ppr res \end{code} +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a function having bottom as its demand result is applied to a less +number of arguments than its syntactic arity, we cannot say for sure +that it is going to diverge. This is the reason why we use the +function appIsBottom, which, given a strictness signature and a number +of arguments, says conservatively if the function is going to diverge +or not. + Zap absence or one-shot information, under control of flags \begin{code} diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index ab58a4f9f5..6b464542a5 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -83,7 +83,6 @@ import Data.Bits import Data.Data import Data.List import Data.Ord -import System.FilePath \end{code} %************************************************************************ @@ -191,15 +190,19 @@ cmpRealSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) instance Outputable RealSrcLoc where ppr (SrcLoc src_path src_line src_col) - = getPprStyle $ \ sty -> - if userStyle sty || debugStyle sty then - hcat [ pprFastFilePath src_path, char ':', - int src_line, - char ':', int src_col - ] - else - hcat [text "{-# LINE ", int src_line, space, - char '\"', pprFastFilePath src_path, text " #-}"] + = hcat [ pprFastFilePath src_path <> colon + , int src_line <> colon + , int src_col ] + +-- I don't know why there is this style-based difference +-- if userStyle sty || debugStyle sty then +-- hcat [ pprFastFilePath src_path, char ':', +-- int src_line, +-- char ':', int src_col +-- ] +-- else +-- hcat [text "{-# LINE ", int src_line, space, +-- char '\"', pprFastFilePath src_path, text " #-}"] instance Outputable SrcLoc where ppr (RealSrcLoc l) = ppr l @@ -432,50 +435,56 @@ instance Ord SrcSpan where instance Outputable RealSrcSpan where - ppr span - = getPprStyle $ \ sty -> - if userStyle sty || debugStyle sty then - text (showUserRealSpan True span) - else - hcat [text "{-# LINE ", int (srcSpanStartLine span), space, - char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] + ppr span = pprUserRealSpan True span + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- text (showUserRealSpan True span) +-- else +-- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, +-- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] instance Outputable SrcSpan where - ppr span - = getPprStyle $ \ sty -> - if userStyle sty || debugStyle sty then - pprUserSpan True span - else - case span of - UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" - RealSrcSpan s -> ppr s + ppr span = pprUserSpan True span -pprUserSpan :: Bool -> SrcSpan -> SDoc -pprUserSpan _ (UnhelpfulSpan s) = ftext s -pprUserSpan show_path (RealSrcSpan s) = text (showUserRealSpan show_path s) +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- pprUserSpan True span +-- else +-- case span of +-- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" +-- RealSrcSpan s -> ppr s showUserSpan :: Bool -> SrcSpan -> String -showUserSpan _ (UnhelpfulSpan s) = unpackFS s -showUserSpan show_path (RealSrcSpan s) = showUserRealSpan show_path s - -showUserRealSpan :: Bool -> RealSrcSpan -> String -showUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col) - = (if show_path then normalise (unpackFS src_path) ++ ":" else "") - ++ show line ++ ":" ++ show start_col - ++ (if end_col - start_col <= 1 then "" else '-' : show (end_col - 1)) +showUserSpan show_path span = showSDocSimple (pprUserSpan show_path span) + +pprUserSpan :: Bool -> SrcSpan -> SDoc +pprUserSpan _ (UnhelpfulSpan s) = ftext s +pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s + +pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc +pprUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col) + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int start_col + , ppUnless (end_col - start_col <= 1) (char '-' <> int (end_col - 1)) ] -- For single-character or point spans, we just -- output the starting column number -showUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol) - = (if show_path then normalise (unpackFS src_path) ++ ":" else "") - ++ "(" ++ show sline ++ "," ++ show scol ++ ")" - ++ "-" - ++ "(" ++ show eline ++ "," ++ show ecol' ++ ")" - where ecol' = if ecol == 0 then ecol else ecol - 1 - -showUserRealSpan show_path (SrcSpanPoint src_path line col) - = (if show_path then normalise (unpackFS src_path) ++ ":" else "") - ++ show line ++ ":" ++ show col +pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol) + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , parens (int sline <> comma <> int scol) + , char '-' + , parens (int eline <> comma <> int ecol') ] + where + ecol' = if ecol == 0 then ecol else ecol - 1 + +pprUserRealSpan show_path (SrcSpanPoint src_path line col) + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int col ] \end{code} %************************************************************************ diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index f7e5f6752a..62253c8642 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -206,16 +206,16 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds \begin{code} instance Outputable Var where - ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var)) --- Printing the type on every occurrence is too much! --- <+> if (not (gopt Opt_SuppressVarKinds dflags)) --- then ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")") --- else empty - -ppr_debug :: Var -> SDoc -ppr_debug (TyVar {}) = ptext (sLit "tv") -ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d -ppr_debug (Id { idScope = s, id_details = d }) = ppr_id_scope s <> pprIdDetails d + ppr var = ppr (varName var) <> getPprStyle (ppr_debug var) + +ppr_debug :: Var -> PprStyle -> SDoc +ppr_debug (TyVar {}) sty + | debugStyle sty = brackets (ptext (sLit "tv")) +ppr_debug (TcTyVar {tc_tv_details = d}) sty + | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) +ppr_debug (Id { idScope = s, id_details = d }) sty + | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d) +ppr_debug _ _ = empty ppr_id_scope :: IdScope -> SDoc ppr_id_scope GlobalId = ptext (sLit "gid") diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 7ef5d42d72..374b98ece9 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -21,7 +21,7 @@ import PrelNames import CoreUtils import CoreArity import CoreFVs -import CoreMonad ( endPass, CoreToDo(..) ) +import CoreMonad ( endPassIO, CoreToDo(..) ) import CoreSyn import CoreSubst import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here @@ -172,7 +172,7 @@ corePrepPgm dflags hsc_env binds data_tycons = do floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds return (deFloatTop (floats1 `appendFloats` floats2)) - endPass hsc_env CorePrep binds_out [] + endPassIO hsc_env alwaysQualify CorePrep binds_out [] return binds_out corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index c979f9908f..e2170e7dd4 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -39,7 +39,7 @@ import Rules import TysPrim (eqReprPrimTyCon) import TysWiredIn (coercibleTyCon ) import BasicTypes ( Activation(.. ) ) -import CoreMonad ( endPass, CoreToDo(..) ) +import CoreMonad ( endPassIO, CoreToDo(..) ) import MkCore import FastString import ErrUtils @@ -94,6 +94,7 @@ deSugar hsc_env tcg_hpc = other_hpc_info }) = do { let dflags = hsc_dflags hsc_env + print_unqual = mkPrintUnqualified dflags rdr_env ; showPass dflags "Desugar" -- Desugar the program @@ -147,14 +148,14 @@ deSugar hsc_env #ifdef DEBUG -- Debug only as pre-simple-optimisation program may be really big - ; endPass hsc_env CoreDesugar final_pgm rules_for_imps + ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps #endif ; (ds_binds, ds_rules_for_imps, ds_vects) <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0 -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code - ; endPass hsc_env CoreDesugarOpt ds_binds ds_rules_for_imps + ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps ; let used_names = mkUsedNames tcg_env ; deps <- mkDependencies tcg_env diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 8c2541c3b6..a3aac1b5a3 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -51,6 +51,7 @@ import Class import DataCon ( dataConWorkId ) import Name import MkId ( seqId ) +import IdInfo ( IdDetails(..) ) import Var import VarSet import Rules @@ -214,6 +215,9 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs | is_default_method -- Default methods are *always* inlined = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) + | DFunId _ is_newtype <- idDetails gbl_id + = (mk_dfun_w_stuff is_newtype, rhs) + | otherwise = case inlinePragmaSpec inline_prag of EmptyInlineSpec -> (gbl_id, rhs) @@ -237,6 +241,22 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs) + -- See Note [ClassOp/DFun selection] in TcInstDcls + -- See Note [Single-method classes] in TcInstDcls + mk_dfun_w_stuff is_newtype + | is_newtype + = gbl_id `setIdUnfolding` mkInlineUnfolding (Just 0) rhs + `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } + | otherwise + = gbl_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dfun_constr dfun_args + `setInlinePragma` dfunInlinePragma + (dfun_bndrs, dfun_body) = collectBinders (simpleOptExpr rhs) + (dfun_con, dfun_args) = collectArgs dfun_body + dfun_constr | Var id <- dfun_con + , DataConWorkId con <- idDetails id + = con + | otherwise = pprPanic "makeCorePair: dfun" (ppr rhs) + dictArity :: [Var] -> Arity -- Don't count coercion variables in arity diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 0932749649..6422eb7ce9 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -406,6 +406,7 @@ Library TcUnify TcInteract TcCanonical + TcFlatten TcSMonad TcTypeNats TcSplice diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index bd1532904e..26aad6f975 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -29,6 +29,7 @@ import Kind import GHC import Outputable import PprTyThing +import ErrUtils import MonadUtils import DynFlags import Exception diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 0b69492b0a..1f751d1d23 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -596,7 +596,7 @@ liftTcM = id newVar :: Kind -> TR TcType newVar = liftTcM . newFlexiTyVarTy -instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst) +instTyVars :: [TyVar] -> TR (TvSubst, [TcTyVar]) -- Instantiate fresh mutable type variables from some TyVars -- This function preserves the print-name, which helps error messages instTyVars = liftTcM . tcInstTyVars @@ -613,7 +613,7 @@ type RttiInstantiation = [(TcTyVar, TyVar)] -- mapping from new (instantiated) -to- old (skolem) type variables instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation) instScheme (tvs, ty) - = liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs + = liftTcM $ do { (subst, tvs') <- tcInstTyVars tvs ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] ; return (substTy subst ty, rtti_inst) } @@ -950,7 +950,7 @@ getDataConArgTys dc con_app_ty = do { let UnaryRep rep_con_app_ty = repType con_app_ty ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty))) - ; (_, _, subst) <- instTyVars (univ_tvs ++ ex_tvs) + ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs) ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) -- See Note [Constructor arg types] ; let con_arg_tys = substTys subst (dataConRepArgTys dc) @@ -1183,8 +1183,8 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') | otherwise = do traceTR (text "(Upgrade) upgraded " <> ppr ty <> text " in presence of newtype evidence " <> ppr new_tycon) - (_, vars, _) <- instTyVars (tyConTyVars new_tycon) - let ty' = mkTyConApp new_tycon vars + (_, vars) <- instTyVars (tyConTyVars new_tycon) + let ty' = mkTyConApp new_tycon (mkTyVarTys vars) UnaryRep rep_ty = repType ty' _ <- liftTcM (unifyType ty rep_ty) -- assumes that reptype doesn't ^^^^ touch tyconApp args diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 166ceba4a2..2831eecf72 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -52,8 +52,6 @@ module DynFlags ( tablesNextToCode, mkTablesNextToCode, SigOf(..), getSigOf, - printOutputForUser, printInfoForUser, - Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, wayGeneralFlags, wayUnsetGeneralFlags, @@ -1557,16 +1555,6 @@ newtype FlushErr = FlushErr (IO ()) defaultFlushErr :: FlushErr defaultFlushErr = FlushErr $ hFlush stderr -printOutputForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO () -printOutputForUser = printSevForUser SevOutput - -printInfoForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO () -printInfoForUser = printSevForUser SevInfo - -printSevForUser :: Severity -> DynFlags -> PrintUnqualified -> SDoc -> IO () -printSevForUser sev dflags unqual doc - = log_action dflags dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc - {- Note [Verbosity levels] ~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index c43064e7f1..8a4763913f 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -27,7 +27,8 @@ module ErrUtils ( mkDumpDoc, dumpSDoc, -- * Messages during compilation - putMsg, putMsgWith, + putMsg, printInfoForUser, printOutputForUser, + logInfo, logOutput, errorMsg, fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'', compilationProgressMsg, @@ -237,7 +238,7 @@ dumpIfSet dflags flag hdr doc dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc | dopt flag dflags - = dumpSDoc dflags flag hdr doc + = dumpSDoc dflags alwaysQualify flag hdr doc | otherwise = return () @@ -254,12 +255,13 @@ mkDumpDoc hdr doc -- | Write out a dump. -- If --dump-to-file is set then this goes to a file. -- otherwise emit to stdout. --- +-- -- When hdr is empty, we print in a more compact format (no separators and -- blank lines) -dumpSDoc :: DynFlags -> DumpFlag -> String -> SDoc -> IO () -dumpSDoc dflags flag hdr doc +dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () +dumpSDoc dflags print_unqual flag hdr doc = do let mFile = chooseDumpFile dflags flag + dump_style = mkDumpStyle print_unqual case mFile of Just fileName -> do @@ -278,7 +280,7 @@ dumpSDoc dflags flag hdr doc $$ blankLine $$ doc return $ mkDumpDoc hdr d - defaultLogActionHPrintDoc dflags handle doc' defaultDumpStyle + defaultLogActionHPrintDoc dflags handle doc' dump_style hClose handle -- write the dump to stdout @@ -286,7 +288,7 @@ dumpSDoc dflags flag hdr doc let (doc', severity) | null hdr = (doc, SevOutput) | otherwise = (mkDumpDoc hdr doc, SevDump) - log_action dflags dflags severity noSrcSpan defaultDumpStyle doc' + log_action dflags dflags severity noSrcSpan dump_style doc' -- | Choose where to put a dump file based on DynFlags @@ -340,18 +342,9 @@ ifVerbose dflags val act | verbosity dflags >= val = act | otherwise = return () -putMsg :: DynFlags -> MsgDoc -> IO () -putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg - -putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () -putMsgWith dflags print_unqual msg - = log_action dflags dflags SevInfo noSrcSpan sty msg - where - sty = mkUserStyle print_unqual AllTheWay - errorMsg :: DynFlags -> MsgDoc -> IO () -errorMsg dflags msg = - log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg +errorMsg dflags msg + = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg fatalErrorMsg :: DynFlags -> MsgDoc -> IO () fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg @@ -365,25 +358,45 @@ fatalErrorMsg'' fm msg = fm msg compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg - = ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg)) + = ifVerbose dflags 1 $ + logOutput dflags defaultUserStyle (text msg) showPass :: DynFlags -> String -> IO () showPass dflags what - = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) + = ifVerbose dflags 2 $ + logInfo dflags defaultUserStyle (text "***" <+> text what <> colon) debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () -debugTraceMsg dflags val msg - = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg) +debugTraceMsg dflags val msg = ifVerbose dflags val $ + logInfo dflags defaultDumpStyle msg + +putMsg :: DynFlags -> MsgDoc -> IO () +putMsg dflags msg = logInfo dflags defaultUserStyle msg + +printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printInfoForUser dflags print_unqual msg + = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg + +printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printOutputForUser dflags print_unqual msg + = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg + +logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO () +logInfo dflags sty msg = log_action dflags dflags SevInfo noSrcSpan sty msg + +logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO () +-- Like logInfo but with SevOutput rather then SevInfo +logOutput dflags sty msg = log_action dflags dflags SevOutput noSrcSpan sty msg prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a prettyPrintGhcErrors dflags = ghandle $ \e -> case e of PprPanic str doc -> - pprDebugAndThen dflags panic str doc + pprDebugAndThen dflags panic (text str) doc PprSorry str doc -> - pprDebugAndThen dflags sorry str doc + pprDebugAndThen dflags sorry (text str) doc PprProgramError str doc -> - pprDebugAndThen dflags pgmError str doc + pprDebugAndThen dflags pgmError (text str) doc _ -> liftIO $ throwIO e \end{code} diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index eed4671b67..240e63b5b6 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -128,7 +128,7 @@ pprTyThingInContextLoc tyThing ------------------------ ppr_ty_thing :: Bool -> [OccName] -> TyThing -> SDoc -- We pretty-print 'TyThing' via 'IfaceDecl' --- See Note [Pretty-pringint TyThings] +-- See Note [Pretty-printing TyThings] ppr_ty_thing hdr_only path ty_thing = pprIfaceDecl ss (tyThingToIfaceDecl ty_thing) where diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 02db8efec0..a975fdd5ac 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -141,7 +141,7 @@ mkBootModDetailsTc hsc_env tcg_fam_insts = fam_insts } = do { let dflags = hsc_dflags hsc_env - ; showPass dflags CoreTidy + ; showPassIO dflags CoreTidy ; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts ; type_env1 = mkBootTypeEnv (availsToNameSet exports) @@ -302,6 +302,7 @@ RHSs, so that they print nicely in interfaces. tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) tidyProgram hsc_env (ModGuts { mg_module = mod , mg_exports = exports + , mg_rdr_env = rdr_env , mg_tcs = tcs , mg_insts = insts , mg_fam_insts = fam_insts @@ -319,8 +320,9 @@ tidyProgram hsc_env (ModGuts { mg_module = mod = do { let { dflags = hsc_dflags hsc_env ; omit_prags = gopt Opt_OmitInterfacePragmas dflags ; expose_all = gopt Opt_ExposeAllUnfoldings dflags + ; print_unqual = mkPrintUnqualified dflags rdr_env } - ; showPass dflags CoreTidy + ; showPassIO dflags CoreTidy ; let { type_env = typeEnvFromEntities [] tcs fam_insts @@ -378,7 +380,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } - ; endPass hsc_env CoreTidy all_tidy_binds tidy_rules + ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules -- If the endPass didn't print the rules, but ddump-rules is -- on, print now diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 5b4a517cbb..56c18ea152 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -316,8 +316,7 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof) $ [ Color.raGraph stat | stat@Color.RegAllocStatsStart{} <- stats] - dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" - $ Color.pprStats stats graphGlobal + dump_stats (Color.pprStats stats graphGlobal) dumpIfSet_dyn dflags Opt_D_dump_asm_conflicts "Register conflict graph" @@ -332,13 +331,14 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof) -- dump global NCG stats for linear allocator (case concat $ catMaybes linearStats of [] -> return () - stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" - $ Linear.pprStats (concat native) stats) + stats -> dump_stats (Linear.pprStats (concat native) stats)) -- write out the imports Pretty.printDoc Pretty.LeftMode (pprCols dflags) h $ withPprStyleDoc dflags (mkCodeStyle AsmStyle) $ makeImportsDoc dflags (concat imports) + where + dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats" cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 4e98739905..e1f5299b4f 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -366,10 +366,13 @@ genericTyConNames :: [Name] genericTyConNames = [ v1TyConName, u1TyConName, par1TyConName, rec1TyConName, k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, pTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, par0TyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, d1TyConName, c1TyConName, s1TyConName, noSelTyConName, - repTyConName, rep1TyConName + repTyConName, rep1TyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName ] \end{code} @@ -388,8 +391,9 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING, - gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST, - gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, + gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST, gHC_TUPLE, + dATA_TUPLE, dATA_EITHER, dATA_MAYBE, dATA_STRING, + dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, @@ -415,6 +419,7 @@ gHC_LIST = mkBaseModule (fsLit "GHC.List") gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") dATA_EITHER = mkBaseModule (fsLit "Data.Either") +dATA_MAYBE = mkBaseModule (fsLit "Data.Maybe") dATA_STRING = mkBaseModule (fsLit "Data.String") dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") @@ -723,7 +728,6 @@ leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative") rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative") notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative") - fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR, traverse_RDR, mempty_RDR, mappend_RDR :: RdrName fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") @@ -779,17 +783,24 @@ eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey +maybeTyConName, justDataConName, nothingDataConName :: Name +maybeTyConName = tcQual gHC_BASE (fsLit "Maybe") maybeTyConKey +justDataConName = conName gHC_BASE (fsLit "Just") justDataConKey +nothingDataConName = conName gHC_BASE (fsLit "Nothing") nothingDataConKey + -- Generics (types) -v1TyConName, u1TyConName, par1TyConName, rec1TyConName, +v1TyConName, u1TyConName, rec1TyConName, par1TyConName, k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, pTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, par0TyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, d1TyConName, c1TyConName, s1TyConName, noSelTyConName, - repTyConName, rep1TyConName :: Name + repTyConName, rep1TyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey -par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey @@ -799,13 +810,12 @@ prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey -pTyConName = tcQual gHC_GENERICS (fsLit "P") pTyConKey dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey -par0TyConName = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey +par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey @@ -814,6 +824,16 @@ noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey +prefixIDataConName = conName gHC_GENERICS (fsLit "PrefixI") prefixIDataConKey +infixIDataConName = conName gHC_GENERICS (fsLit "InfixI") infixIDataConKey +leftAssociativeDataConName = conName gHC_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey +rightAssociativeDataConName = conName gHC_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey +notAssociativeDataConName = conName gHC_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey + +metaDataDataConName = conName gHC_GENERICS (fsLit "MetaData") metaDataDataConKey +metaConsDataConName = conName gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey +metaSelDataConName = conName gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey + -- Base strings Strings unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, stringTyConName :: Name @@ -1440,9 +1460,12 @@ stringTyConKey = mkPreludeTyConUnique 134 v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, compTyConKey, rTyConKey, pTyConKey, dTyConKey, - cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey, + cTyConKey, sTyConKey, rec0TyConKey, d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, - repTyConKey, rep1TyConKey :: Unique + repTyConKey, rep1TyConKey, + prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey, + rightAssociativeDataConKey, notAssociativeDataConKey, + metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique v1TyConKey = mkPreludeTyConUnique 135 u1TyConKey = mkPreludeTyConUnique 136 @@ -1462,7 +1485,6 @@ cTyConKey = mkPreludeTyConUnique 147 sTyConKey = mkPreludeTyConUnique 148 rec0TyConKey = mkPreludeTyConUnique 149 -par0TyConKey = mkPreludeTyConUnique 150 d1TyConKey = mkPreludeTyConUnique 151 c1TyConKey = mkPreludeTyConUnique 152 s1TyConKey = mkPreludeTyConUnique 153 @@ -1471,6 +1493,16 @@ noSelTyConKey = mkPreludeTyConUnique 154 repTyConKey = mkPreludeTyConUnique 155 rep1TyConKey = mkPreludeTyConUnique 156 +prefixIDataConKey = mkPreludeDataConUnique 35 +infixIDataConKey = mkPreludeDataConUnique 36 +leftAssociativeDataConKey = mkPreludeDataConUnique 37 +rightAssociativeDataConKey = mkPreludeDataConUnique 38 +notAssociativeDataConKey = mkPreludeDataConUnique 39 + +metaDataDataConKey = mkPreludeDataConUnique 40 +metaConsDataConKey = mkPreludeDataConUnique 41 +metaSelDataConKey = mkPreludeDataConUnique 42 + -- Type-level naturals typeNatKindConNameKey, typeSymbolKindConNameKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, @@ -1501,6 +1533,9 @@ specTyConKey = mkPreludeTyConUnique 177 smallArrayPrimTyConKey = mkPreludeTyConUnique 178 smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 179 +maybeTyConKey :: Unique +maybeTyConKey = mkPreludeTyConUnique 180 + ---------------- Template Haskell ------------------- -- USES TyConUniques 200-299 ----------------------------------------------------- @@ -1563,6 +1598,10 @@ eqDataConKey = mkPreludeDataConUnique 28 gtDataConKey = mkPreludeDataConUnique 29 coercibleDataConKey = mkPreludeDataConUnique 32 + +justDataConKey, nothingDataConKey :: Unique +justDataConKey = mkPreludeDataConUnique 33 +nothingDataConKey = mkPreludeDataConUnique 34 \end{code} %************************************************************************ diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 8d2d3bf9a2..3405f52ed3 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -28,6 +28,7 @@ module CoreMonad ( -- ** Reading from the monad getHscEnv, getRuleBase, getModule, getDynFlags, getOrigNameCache, getPackageFamInstEnv, + getPrintUnqualified, -- ** Writing to the monad addSimplCount, @@ -43,7 +44,7 @@ module CoreMonad ( getAnnotations, getFirstAnnotations, -- ** Debug output - showPass, endPass, dumpPassResult, lintPassResult, + showPass, showPassIO, endPass, endPassIO, dumpPassResult, lintPassResult, lintInteractiveExpr, dumpIfSet, -- ** Screen output @@ -132,15 +133,28 @@ be, and it makes a conveneint place. place for them. They print out stuff before and after core passes, and do Core Lint when necessary. \begin{code} -showPass :: DynFlags -> CoreToDo -> IO () -showPass dflags pass = Err.showPass dflags (showPpr dflags pass) - -endPass :: HscEnv -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () -endPass hsc_env pass binds rules - = do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules +showPass :: CoreToDo -> CoreM () +showPass pass = do { dflags <- getDynFlags + ; liftIO $ showPassIO dflags pass } + +showPassIO :: DynFlags -> CoreToDo -> IO () +showPassIO dflags pass = Err.showPass dflags (showPpr dflags pass) + +endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () +endPass pass binds rules + = do { hsc_env <- getHscEnv + ; print_unqual <- getPrintUnqualified + ; liftIO $ endPassIO hsc_env print_unqual pass binds rules } + +endPassIO :: HscEnv -> PrintUnqualified + -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () +-- Used by the IO-is CorePrep too +endPassIO hsc_env print_unqual pass binds rules + = do { dumpPassResult dflags print_unqual mb_flag + (ppr pass) (pprPassDetails pass) binds rules ; lintPassResult hsc_env pass binds } where - dflags = hsc_dflags hsc_env + dflags = hsc_dflags hsc_env mb_flag = case coreDumpFlag pass of Just flag | dopt flag dflags -> Just flag | dopt Opt_D_verbose_core2core dflags -> Just flag @@ -151,15 +165,16 @@ dumpIfSet dflags dump_me pass extra_info doc = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc dumpPassResult :: DynFlags - -> Maybe DumpFlag -- Just df => show details in a file whose + -> PrintUnqualified + -> Maybe DumpFlag -- Just df => show details in a file whose -- name is specified by df -> SDoc -- Header -> SDoc -- Extra info to appear after header -> CoreProgram -> [CoreRule] -> IO () -dumpPassResult dflags mb_flag hdr extra_info binds rules +dumpPassResult dflags unqual mb_flag hdr extra_info binds rules | Just flag <- mb_flag - = Err.dumpSDoc dflags flag (showSDoc dflags hdr) dump_doc + = Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc | otherwise = Err.debugTraceMsg dflags 2 size_doc @@ -781,6 +796,7 @@ data CoreReader = CoreReader { cr_hsc_env :: HscEnv, cr_rule_base :: RuleBase, cr_module :: Module, + cr_print_unqual :: PrintUnqualified, #ifdef GHCI cr_globals :: (MVar PersistentLinkerState, Bool) #else @@ -854,9 +870,10 @@ runCoreM :: HscEnv -> RuleBase -> UniqSupply -> Module + -> PrintUnqualified -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env rule_base us mod m = do +runCoreM hsc_env rule_base us mod print_unqual m = do glbls <- saveLinkerGlobals liftM extract $ runIOEnv (reader glbls) $ unCoreM m state where @@ -864,7 +881,8 @@ runCoreM hsc_env rule_base us mod m = do cr_hsc_env = hsc_env, cr_rule_base = rule_base, cr_module = mod, - cr_globals = glbls + cr_globals = glbls, + cr_print_unqual = print_unqual } state = CoreState { cs_uniq_supply = us @@ -934,6 +952,9 @@ getHscEnv = read cr_hsc_env getRuleBase :: CoreM RuleBase getRuleBase = read cr_rule_base +getPrintUnqualified :: CoreM PrintUnqualified +getPrintUnqualified = read cr_print_unqual + addSimplCount :: SimplCount -> CoreM () addSimplCount count = write (CoreWriter { cw_simpl_count = count }) diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 0fbd2cac99..ef212bca85 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -1380,13 +1380,13 @@ The occurrrence analyser propagates one-shot-lambda information in two situation Propagate one-shot info from the strictness signature of 'build' to the \cn - * Let-bindings: eg let f = \c. let ... in \n -> blah + * Let-bindings: eg let f = \c. let ... in \n -> blah in (build f, build f) Propagate one-shot info from the demanand-info on 'f' to the lambdas in its RHS (which may not be syntactically at the top) Some of this is done by the demand analyser, but this way it happens -much earlier, taking advantage of the strictness signature of +much earlier, taking advantage of the strictness signature of imported functions. Note [Binders in case alternatives] diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index e5cd42ec30..b8726d93a4 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -827,6 +827,7 @@ lvlLamBndrs env lvl bndrs is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr) -- The "probably" part says "don't float things out of a -- probable one-shot lambda" + -- See Note [Computing one-shot info] in Demand.lhs lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr]) diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 2a70dcfdbb..8908cb3ced 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -76,9 +76,9 @@ core2core hsc_env guts ; let builtin_passes = getCoreToDo dflags ; - ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ - do { all_passes <- addPluginPasses dflags builtin_passes - ; runCorePasses all_passes guts } + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod print_unqual $ + do { all_passes <- addPluginPasses dflags builtin_passes + ; runCorePasses all_passes guts } {-- ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline @@ -99,6 +99,7 @@ core2core hsc_env guts -- consume the ModGuts to find the module) but somewhat ugly because mg_module may -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which -- would mean our cached value would go out of date. + print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts) \end{code} @@ -384,11 +385,9 @@ runCorePasses passes guts do_pass guts CoreDoNothing = return guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts do_pass guts pass - = do { hsc_env <- getHscEnv - ; let dflags = hsc_dflags hsc_env - ; liftIO $ showPass dflags pass + = do { showPass pass ; guts' <- doCorePass pass guts - ; liftIO $ endPass hsc_env pass (mg_binds guts') (mg_rules guts') + ; endPass pass (mg_binds guts') (mg_rules guts') ; return guts' } doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts @@ -596,6 +595,7 @@ simplifyPgmIO :: CoreToDo simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) hsc_env us hpt_rule_base guts@(ModGuts { mg_module = this_mod + , mg_rdr_env = rdr_env , mg_binds = binds, mg_rules = rules , mg_fam_inst_env = fam_inst_env }) = do { (termination_msg, it_count, counts_out, guts') @@ -610,10 +610,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) ; return (counts_out, guts') } where - dflags = hsc_dflags hsc_env - dump_phase = dumpSimplPhase dflags mode - simpl_env = mkSimplEnv mode - active_rule = activeRule simpl_env + dflags = hsc_dflags hsc_env + print_unqual = mkPrintUnqualified dflags rdr_env + dump_phase = dumpSimplPhase dflags mode + simpl_env = mkSimplEnv mode + active_rule = activeRule simpl_env do_iteration :: UniqSupply -> Int -- Counts iterations @@ -709,7 +710,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - dump_end_iteration dflags iteration_no counts1 binds2 rules1 ; + dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ; lintPassResult hsc_env pass binds2 ; -- Loop @@ -727,10 +728,10 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" ------------------- -dump_end_iteration :: DynFlags -> Int - -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration dflags iteration_no counts binds rules - = dumpPassResult dflags mb_flag hdr pp_counts binds rules +dump_end_iteration :: DynFlags -> PrintUnqualified -> Int + -> SimplCount -> CoreProgram -> [CoreRule] -> IO () +dump_end_iteration dflags print_unqual iteration_no counts binds rules + = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules where mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases | otherwise = Nothing diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 6a908836e2..e5561b2fc0 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -29,6 +29,7 @@ import CoreMonad import Outputable import FastString import MonadUtils +import ErrUtils import Control.Monad ( when, liftM, ap ) \end{code} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index f044be5ab8..cc55529906 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1615,8 +1615,9 @@ tryRules env rules fn args call_cont | otherwise = return () - log_rule dflags flag hdr details = liftIO . dumpSDoc dflags flag "" $ - sep [text hdr, nest 4 details] + log_rule dflags flag hdr details + = liftIO . dumpSDoc dflags alwaysQualify flag "" $ + sep [text hdr, nest 4 details] \end{code} Note [Optimising tagToEnum#] diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 11f97eab07..1f1fbdf745 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -528,7 +528,8 @@ can still be specialised by the type-class specialiser, something like BUT if f is strict in the Ord dictionary, we might unpack it, to get fw :: (a->a->Bool) -> [a] -> Int# -> a -and the type-class specialiser can't specialise that. +and the type-class specialiser can't specialise that. An example is +Trac #6056. Moreover, dictinoaries can have a lot of fields, so unpacking them can increase closure sizes. diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 016dc08a20..08b7e9d3f8 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -56,21 +56,17 @@ newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst -- Called from the vectoriser monad too, hence the rather general type newFamInst flavor axiom@(CoAxiom { co_ax_branches = FirstBranch branch , co_ax_tc = fam_tc }) - = do { (subst, tvs') <- tcInstSigTyVarsLoc loc tvs - ; return (FamInst { fi_fam = fam_tc_name + | CoAxBranch { cab_tvs = tvs + , cab_lhs = lhs + , cab_rhs = rhs } <- branch + = do { (subst, tvs') <- freshenTyVarBndrs tvs + ; return (FamInst { fi_fam = tyConName fam_tc , fi_flavor = flavor , fi_tcs = roughMatchTcs lhs , fi_tvs = tvs' , fi_tys = substTys subst lhs , fi_rhs = substTy subst rhs , fi_axiom = axiom }) } - where - fam_tc_name = tyConName fam_tc - CoAxBranch { cab_loc = loc - , cab_tvs = tvs - , cab_lhs = lhs - , cab_rhs = rhs } = branch - \end{code} diff --git a/compiler/typecheck/Flattening-notes b/compiler/typecheck/Flattening-notes new file mode 100644 index 0000000000..ec4565ccf5 --- /dev/null +++ b/compiler/typecheck/Flattening-notes @@ -0,0 +1,40 @@ +ToDo: + +* get rid of getEvTerm? + +* inert_funeqs, inert_eqs: keep only the CtEvidence. + They are all CFunEqCans, CTyEqCans + +* Consider individual data tpyes for CFunEqCan etc + +* Collapes CNonCanonical and CIrredCan + +Remaining errors +============================ +Unexpected failures: + generics GenDerivOutput1_1 [stderr mismatch] (normal) + +ghcirun002: internal error: ASSERTION FAILED: file rts/Interpreter.c, line 773 + ghci/should_run ghcirun002 [bad exit code] (ghci) + +-package dependencies: array-0.5.0.1@array_GX4NwjS8xZkC2ZPtjgwhnz ++package dependencies: array-0.5.0.1 base-4.8.0.0 + safeHaskell/check/pkg01 safePkg01 [bad stdout] (normal) + + +Wierd looking pattern synonym thing + ghci/scripts T8776 [bad stdout] (ghci) + patsyn/should_fail mono [stderr mismatch] (normal) + +Derived equalities fmv1 ~ Maybe a, fmv2 ~ Maybe b + indexed-types/should_fail T4093a [stderr mismatch] (normal) + +Not sure + indexed-types/should_fail ExtraTcsUntch [stderr mismatch] (normal) + +Order of finding iprovements + typecheck/should_compile TcTypeNatSimple [exit code non-0] (normal) + + + +----------------- diff --git a/compiler/typecheck/FunDeps.lhs b/compiler/typecheck/FunDeps.lhs index 283886e836..36dc641910 100644 --- a/compiler/typecheck/FunDeps.lhs +++ b/compiler/typecheck/FunDeps.lhs @@ -15,7 +15,7 @@ module FunDeps ( Equation(..), pprEquation, improveFromInstEnv, improveFromAnother, checkInstCoverage, checkFunDeps, - growThetaTyVars, pprFundeps + pprFundeps ) where #include "HsVersions.h" @@ -41,46 +41,6 @@ import Data.Maybe ( isJust ) %************************************************************************ %* * -\subsection{Close type variables} -%* * -%************************************************************************ - -Note [Growing the tau-tvs using constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(growThetaTyVars insts tvs) is the result of extending the set - of tyvars tvs using all conceivable links from pred - -E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e} -Then growThetaTyVars preds tvs = {a,b,c} - -Notice that - growThetaTyVars is conservative if v might be fixed by vs - => v `elem` grow(vs,C) - -\begin{code} -growThetaTyVars :: ThetaType -> TyVarSet -> TyVarSet --- See Note [Growing the tau-tvs using constraints] -growThetaTyVars theta tvs - | null theta = tvs - | otherwise = fixVarSet mk_next tvs - where - mk_next tvs = foldr grow_one tvs theta - grow_one pred tvs = growPredTyVars pred tvs `unionVarSet` tvs - -growPredTyVars :: PredType - -> TyVarSet -- The set to extend - -> TyVarSet -- TyVars of the predicate if it intersects the set, -growPredTyVars pred tvs - | isIPPred pred = pred_tvs -- Always quantify over implicit parameers - | pred_tvs `intersectsVarSet` tvs = pred_tvs - | otherwise = emptyVarSet - where - pred_tvs = tyVarsOfType pred -\end{code} - - -%************************************************************************ -%* * \subsection{Generate equations from functional dependencies} %* * %************************************************************************ diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 3405fd4a1e..17366a3aa2 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -15,6 +15,7 @@ module Inst ( newOverloadedLit, mkOverLit, + newClsInst, tcGetInsts, tcGetInstEnvs, getOverlapFlag, tcExtendLocalInstEnv, instCallConstraints, newMethodFromName, tcSyntaxName, @@ -44,6 +45,8 @@ import Type import Coercion ( Role(..) ) import TcType import HscTypes +import Class( Class ) +import MkId( mkDictFunId ) import Id import Name import Var ( EvVar, varType, setVarType ) @@ -168,9 +171,14 @@ deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) deeplyInstantiate orig ty | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty - = do { (_, tys, subst) <- tcInstTyVars tvs + = do { (subst, tvs') <- tcInstTyVars tvs ; ids1 <- newSysLocalIds (fsLit "di") (substTys subst arg_tys) - ; wrap1 <- instCall orig tys (substTheta subst theta) + ; let theta' = substTheta subst theta + ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' + ; traceTc "Instantiating (deply)" (vcat [ ppr ty + , text "with" <+> ppr tvs' + , text "args:" <+> ppr ids1 + , text "theta:" <+> ppr theta' ]) ; (wrap2, rho2) <- deeplyInstantiate orig (substTy subst rho) ; return (mkWpLams ids1 <.> wrap2 @@ -378,18 +386,19 @@ syntaxNameCtxt name orig ty tidy_env %************************************************************************ \begin{code} -getOverlapFlag :: TcM OverlapFlag -getOverlapFlag +getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag +getOverlapFlag overlap_mode = do { dflags <- getDynFlags ; let overlap_ok = xopt Opt_OverlappingInstances dflags incoherent_ok = xopt Opt_IncoherentInstances dflags use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags , overlapMode = x } - overlap_flag | incoherent_ok = use Incoherent - | overlap_ok = use Overlaps - | otherwise = use NoOverlap + default_oflag | incoherent_ok = use Incoherent + | overlap_ok = use Overlaps + | otherwise = use NoOverlap - ; return overlap_flag } + final_oflag = setOverlapModeMaybe default_oflag overlap_mode + ; return final_oflag } tcGetInstEnvs :: TcM (InstEnv, InstEnv) -- Gets both the external-package inst-env @@ -401,6 +410,22 @@ tcGetInsts :: TcM [ClsInst] -- Gets the local class instances. tcGetInsts = fmap tcg_insts getGblEnv +newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType + -> Class -> [Type] -> TcM ClsInst +newClsInst overlap_mode dfun_name tvs theta clas tys + = do { (subst, tvs') <- freshenTyVarBndrs tvs + -- Be sure to freshen those type variables, + -- so they are sure not to appear in any lookup + ; let tys' = substTys subst tys + theta' = substTheta subst theta + dfun = mkDictFunId dfun_name tvs' theta' clas tys' + -- Substituting in the DFun type just makes sure that + -- we are using TyVars rather than TcTyVars + -- Not sure if this is really the right place to do so, + -- but it'll do fine + ; oflag <- getOverlapFlag overlap_mode + ; return (mkLocalInstance dfun oflag tvs' clas tys') } + tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a -- Add new locally-defined instances tcExtendLocalInstEnv dfuns thing_inside @@ -473,52 +498,60 @@ 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: +when you compile a signature against an implementation, you will +see the instances WHETHER OR NOT the instance is declared in +the file (this is because the signatures go in the EPS and we +can't filter them out easily.) This is also why we cannot +place the instance in the hi file: it would show up as a duplicate, +and we don't have instance reexports anyway. + +However, you might find them useful when typechecking against +a signature: the instance is a way of indicating to GHC that +some instance exists, in case downstream code uses it. + +Implementing this is a little tricky. Consider the following +situation (sigof03): + + module A where + instance C T where ... + + module ASig where + instance C T + +When compiling ASig, A.hi is loaded, which brings its instances +into the EPS. When we process the instance declaration in ASig, +we should ignore it for the purpose of doing a duplicate check, +since it's not actually a duplicate. But don't skip the check +entirely, we still want this to fail (tcfail221): + + module ASig where + instance C T + instance C T --- Note [Signature files and type class instances] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Instances in signature files do not have an effect when compiling: --- when you compile a signature against an implementation, you will --- see the instances WHETHER OR NOT the instance is declared in --- the file (this is because the signatures go in the EPS and we --- can't filter them out easily.) This is also why we cannot --- place the instance in the hi file: it would show up as a duplicate, --- and we don't have instance reexports anyway. --- --- However, you might find them useful when typechecking against --- a signature: the instance is a way of indicating to GHC that --- some instance exists, in case downstream code uses it. --- --- Implementing this is a little tricky. Consider the following --- situation (sigof03): --- --- module A where --- instance C T where ... --- --- module ASig where --- instance C T --- --- When compiling ASig, A.hi is loaded, which brings its instances --- into the EPS. When we process the instance declaration in ASig, --- we should ignore it for the purpose of doing a duplicate check, --- since it's not actually a duplicate. But don't skip the check --- entirely, we still want this to fail (tcfail221): --- --- module ASig where --- instance C T --- instance C T --- --- Note that in some situations, the interface containing the type --- class instances may not have been loaded yet at all. The usual --- situation when A imports another module which provides the --- instances (sigof02m): --- --- module A(module B) where --- import B --- --- 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) +Note that in some situations, the interface containing the type +class instances may not have been loaded yet at all. The usual +situation when A imports another module which provides the +instances (sigof02m): + module A(module B) where + import B + +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)) @@ -557,13 +590,12 @@ addClsInstsErr herald ispecs \begin{code} ---------------- Getting free tyvars ------------------------- tyVarsOfCt :: Ct -> TcTyVarSet --- NB: the -tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv -tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys) -tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys -tyVarsOfCt (CIrredEvCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) -tyVarsOfCt (CHoleCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) -tyVarsOfCt (CNonCanonical { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) +tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv +tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) = extendVarSet (tyVarsOfTypes tys) fsk +tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys +tyVarsOfCt (CIrredEvCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) +tyVarsOfCt (CHoleCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) +tyVarsOfCt (CNonCanonical { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) tyVarsOfCts :: Cts -> TcTyVarSet tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet @@ -577,10 +609,10 @@ tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) tyVarsOfImplic :: Implication -> TyVarSet -- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyVarsOfImplic (Implic { ic_skols = skols, ic_fsks = fsks - , ic_given = givens, ic_wanted = wanted }) +tyVarsOfImplic (Implic { ic_skols = skols + , ic_given = givens, ic_wanted = wanted }) = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens)) - `delVarSetList` skols `delVarSetList` fsks + `delVarSetList` skols tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index e96e0be4d9..3741273884 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -31,8 +31,9 @@ import TcPat import TcMType import PatSyn import ConLike +import FamInstEnv( normaliseType ) +import FamInst( tcGetFamInstEnvs ) import Type( tidyOpenType ) -import FunDeps( growThetaTyVars ) import TyCon import TcType import TysPrim @@ -591,14 +592,15 @@ tcPolyInfer -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list - = do { ((binds', mono_infos), wanted) - <- captureConstraints $ + = do { (((binds', mono_infos), untch), wanted) + <- captureConstraints $ + captureUntouchables $ tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos] ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted) ; (qtvs, givens, mr_bites, ev_binds) - <- simplifyInfer closed mono name_taus wanted + <- simplifyInfer untch mono name_taus wanted ; theta <- zonkTcThetaType (map evVarPred givens) ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos @@ -677,15 +679,22 @@ mkInferredPolyId :: Name -> [TyVar] -> TcThetaType -> TcType -> TcM Id -- the right type variables and theta to quantify over -- See Note [Validity of inferred types] mkInferredPolyId poly_name qtvs theta mono_ty - = addErrCtxtM (mk_bind_msg True False poly_name inferred_poly_ty) $ - do { checkValidType (InfSigCtxt poly_name) inferred_poly_ty - ; return (mkLocalId poly_name inferred_poly_ty) } - where - my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType mono_ty)) + = do { fam_envs <- tcGetFamInstEnvs + + ; let (_co, norm_mono_ty) = normaliseType fam_envs Nominal mono_ty + -- Unification may not have normalised the type, so do it + -- here to make it as uncomplicated as possible. + -- Example: f :: [F Int] -> Bool + -- should be rewritten to f :: [Char] -> Bool, if possible + my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType norm_mono_ty)) -- Include kind variables! Trac #7916 - my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order - my_theta = filter (quantifyPred my_tvs2) theta - inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty + my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order + my_theta = filter (quantifyPred my_tvs2) theta + inferred_poly_ty = mkSigmaTy my_tvs my_theta norm_mono_ty + + ; addErrCtxtM (mk_bind_msg True False poly_name inferred_poly_ty) $ + checkValidType (InfSigCtxt poly_name) inferred_poly_ty + ; return (mkLocalId poly_name inferred_poly_ty) } mk_bind_msg :: Bool -> Bool -> Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_bind_msg inferred want_ambig poly_name poly_ty tidy_env diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index d58d5db40f..dddceb63b5 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -1,10 +1,7 @@ \begin{code} {-# LANGUAGE CPP #-} -module TcCanonical( - canonicalize, emitWorkNC, - StopOrContinue (..) - ) where +module TcCanonical( canonicalize ) where #include "HsVersions.h" @@ -12,23 +9,22 @@ import TcRnTypes import TcType import Type import Kind +import TcFlatten +import TcSMonad import TcEvidence import Class import TyCon import TypeRep import Var -import VarEnv +import Name( isSystemName ) import OccName( OccName ) import Outputable import Control.Monad ( when ) import DynFlags( DynFlags ) import VarSet -import TcSMonad -import FastString import Util import BasicTypes -import Maybes( catMaybes ) \end{code} @@ -71,35 +67,6 @@ phase cannot be rewritten any further from the inerts (but maybe /it/ can rewrite an inert or still interact with an inert in a further phase in the simplifier. -\begin{code} - --- Informative results of canonicalization -data StopOrContinue - = ContinueWith Ct -- Either no canonicalization happened, or if some did - -- happen, it is still safe to just keep going with this - -- work item. - | Stop -- Some canonicalization happened, extra work is now in - -- the TcS WorkList. - -instance Outputable StopOrContinue where - ppr Stop = ptext (sLit "Stop") - ppr (ContinueWith w) = ptext (sLit "ContinueWith") <+> ppr w - - -continueWith :: Ct -> TcS StopOrContinue -continueWith = return . ContinueWith - -andWhenContinue :: TcS StopOrContinue - -> (Ct -> TcS StopOrContinue) - -> TcS StopOrContinue -andWhenContinue tcs1 tcs2 - = do { r <- tcs1 - ; case r of - Stop -> return Stop - ContinueWith ct -> tcs2 ct } - -\end{code} - Note [Caching for canonicals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Our plan with pre-canonicalization is to be able to solve a constraint @@ -158,7 +125,7 @@ EvBinds, so we are again good. -- Top-level canonicalization -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -canonicalize :: Ct -> TcS StopOrContinue +canonicalize :: Ct -> TcS (StopOrContinue Ct) canonicalize ct@(CNonCanonical { cc_ev = ev }) = do { traceTcS "canonicalize (non-canonical)" (ppr ct) ; {-# SCC "canEvVar" #-} @@ -178,16 +145,16 @@ canonicalize (CTyEqCan { cc_ev = ev canonicalize (CFunEqCan { cc_ev = ev , cc_fun = fn , cc_tyargs = xis1 - , cc_rhs = xi2 }) + , cc_fsk = fsk }) = {-# SCC "canEqLeafFunEq" #-} - canEqLeafFun ev NotSwapped fn xis1 xi2 xi2 + canCFunEqCan ev fn xis1 fsk canonicalize (CIrredEvCan { cc_ev = ev }) = canIrred ev canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ }) = canHole ev occ -canEvNC :: CtEvidence -> TcS StopOrContinue +canEvNC :: CtEvidence -> TcS (StopOrContinue Ct) -- Called only for non-canonical EvVars canEvNC ev = case classifyPredType (ctEvPred ev) of @@ -205,13 +172,13 @@ canEvNC ev %************************************************************************ \begin{code} -canTuple :: CtEvidence -> [PredType] -> TcS StopOrContinue +canTuple :: CtEvidence -> [PredType] -> TcS (StopOrContinue Ct) canTuple ev tys = do { traceTcS "can_pred" (text "TuplePred!") ; let xcomp = EvTupleMk xdecomp x = zipWith (\_ i -> EvTupleSel x i) tys [0..] - ; ctevs <- xCtEvidence ev (XEvTerm tys xcomp xdecomp) - ; canEvVarsCreated ctevs } + ; xCtEvidence ev (XEvTerm tys xcomp xdecomp) + ; stopWith ev "Decomposed tuple constraint" } \end{code} %************************************************************************ @@ -223,7 +190,7 @@ canTuple ev tys \begin{code} canClass, canClassNC :: CtEvidence - -> Class -> [Type] -> TcS StopOrContinue + -> Class -> [Type] -> TcS (StopOrContinue Ct) -- Precondition: EvVar is class evidence -- The canClassNC version is used on non-canonical constraints @@ -236,19 +203,18 @@ canClassNC ev cls tys `andWhenContinue` emitSuperclasses canClass ev cls tys - = do { (xis, cos) <- flattenMany FMFullFlatten ev tys + = do { let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll } + ; (xis, cos) <- flattenMany fmode tys ; let co = mkTcTyConAppCo Nominal (classTyCon cls) cos xi = mkClassPred cls xis + mk_ct new_ev = CDictCan { cc_ev = new_ev + , cc_tyargs = xis, cc_class = cls } ; mb <- rewriteEvidence ev xi co ; traceTcS "canClass" (vcat [ ppr ev <+> ppr cls <+> ppr tys , ppr xi, ppr mb ]) - ; case mb of - Nothing -> return Stop - Just new_ev -> continueWith $ - CDictCan { cc_ev = new_ev - , cc_tyargs = xis, cc_class = cls } } + ; return (fmap mk_ct mb) } -emitSuperclasses :: Ct -> TcS StopOrContinue +emitSuperclasses :: Ct -> TcS (StopOrContinue Ct) emitSuperclasses ct@(CDictCan { cc_ev = ev , cc_tyargs = xis_new, cc_class = cls }) -- Add superclasses of this one here, See Note [Adding superclasses]. -- But only if we are not simplifying the LHS of a rule. @@ -337,8 +303,7 @@ newSCWorkFromFlavored flavor cls xis xev = XEvTerm { ev_preds = sc_theta , ev_comp = panic "Can't compose for given!" , ev_decomp = xev_decomp } - ; ctevs <- xCtEvidence flavor xev - ; emitWorkNC ctevs } + ; xCtEvidence flavor xev } | isEmptyVarSet (tyVarsOfTypes xis) = return () -- Wanteds with no variables yield no deriveds. @@ -347,20 +312,19 @@ newSCWorkFromFlavored flavor cls xis | otherwise -- Wanted case, just add those SC that can lead to improvement. = do { let sc_rec_theta = transSuperClasses cls xis impr_theta = filter is_improvement_pty sc_rec_theta - loc = ctev_loc flavor + loc = ctEvLoc flavor ; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta - ; mb_der_evs <- mapM (newDerived loc) impr_theta - ; emitWorkNC (catMaybes mb_der_evs) } + ; mapM_ (emitNewDerived loc) impr_theta } is_improvement_pty :: PredType -> Bool -- Either it's an equality, or has some functional dependency is_improvement_pty ty = go (classifyPredType ty) where - go (EqPred {}) = True + go (EqPred t1 t2) = not (t1 `tcEqType` t2) go (ClassPred cls _tys) = not $ null fundeps - where (_,fundeps) = classTvsFds cls - go (TuplePred ts) = any is_improvement_pty ts - go (IrredPred {}) = True -- Might have equalities after reduction? + where (_,fundeps) = classTvsFds cls + go (TuplePred ts) = any is_improvement_pty ts + go (IrredPred {}) = True -- Might have equalities after reduction? \end{code} @@ -372,16 +336,18 @@ is_improvement_pty ty = go (classifyPredType ty) \begin{code} -canIrred :: CtEvidence -> TcS StopOrContinue +canIrred :: CtEvidence -> TcS (StopOrContinue Ct) -- Precondition: ty not a tuple and no other evidence form canIrred old_ev = do { let old_ty = ctEvPred old_ev + fmode = FE { fe_ev = old_ev, fe_mode = FM_FlattenAll } + -- Flatten (F [a]), say, so that it can reduce to Eq a ; traceTcS "can_pred" (text "IrredPred = " <+> ppr old_ty) - ; (xi,co) <- flatten FMFullFlatten old_ev old_ty -- co :: xi ~ old_ty + ; (xi,co) <- flatten fmode old_ty -- co :: xi ~ old_ty ; mb <- rewriteEvidence old_ev xi co ; case mb of { - Nothing -> return Stop ; - Just new_ev -> + Stop ev s -> return (Stop ev s) ; + ContinueWith new_ev -> do { -- Re-classify, in case flattening has improved its shape ; case classifyPredType (ctEvPred new_ev) of @@ -391,340 +357,18 @@ canIrred old_ev _ -> continueWith $ CIrredEvCan { cc_ev = new_ev } } } } -canHole :: CtEvidence -> OccName -> TcS StopOrContinue +canHole :: CtEvidence -> OccName -> TcS (StopOrContinue Ct) canHole ev occ - = do { let ty = ctEvPred ev - ; (xi,co) <- flatten FMFullFlatten ev ty -- co :: xi ~ ty + = do { let ty = ctEvPred ev + fmode = FE { fe_ev = ev, fe_mode = FM_SubstOnly } + ; (xi,co) <- flatten fmode ty -- co :: xi ~ ty ; mb <- rewriteEvidence ev xi co ; case mb of - Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_occ = occ }) - Nothing -> return () -- Found a cached copy; won't happen - ; return Stop } -\end{code} - -%************************************************************************ -%* * -%* Flattening (eliminating all function symbols) * -%* * -%************************************************************************ - -Note [Flattening] -~~~~~~~~~~~~~~~~~~~~ - flatten ty ==> (xi, cc) - where - xi has no type functions, unless they appear under ForAlls - - cc = Auxiliary given (equality) constraints constraining - the fresh type variables in xi. Evidence for these - is always the identity coercion, because internally the - fresh flattening skolem variables are actually identified - with the types they have been generated to stand in for. - -Note that it is flatten's job to flatten *every type function it sees*. -flatten is only called on *arguments* to type functions, by canEqGiven. - -Recall that in comments we use alpha[flat = ty] to represent a -flattening skolem variable alpha which has been generated to stand in -for ty. - ------ Example of flattening a constraint: ------ - flatten (List (F (G Int))) ==> (xi, cc) - where - xi = List alpha - cc = { G Int ~ beta[flat = G Int], - F beta ~ alpha[flat = F beta] } -Here - * alpha and beta are 'flattening skolem variables'. - * All the constraints in cc are 'given', and all their coercion terms - are the identity. - -NB: Flattening Skolems only occur in canonical constraints, which -are never zonked, so we don't need to worry about zonking doing -accidental unflattening. - -Note that we prefer to leave type synonyms unexpanded when possible, -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 FlattenMode = FMSubstOnly | FMFullFlatten - -- See Note [Flattening under a forall] - --- Flatten a bunch of types all at once. -flattenMany :: FlattenMode - -> CtEvidence - -> [Type] -> TcS ([Xi], [TcCoercion]) --- Coercions :: Xi ~ Type --- Returns True iff (no flattening happened) --- NB: The EvVar inside the 'ctxt :: CtEvidence' is unused, --- we merely want (a) Given/Solved/Derived/Wanted info --- (b) the GivenLoc/WantedLoc for when we create new evidence -flattenMany f ctxt tys - = -- pprTrace "flattenMany" empty $ - go tys - where go [] = return ([],[]) - go (ty:tys) = do { (xi,co) <- flatten f ctxt ty - ; (xis,cos) <- go tys - ; return (xi:xis,co:cos) } - -flatten :: FlattenMode - -> CtEvidence -> TcType -> TcS (Xi, TcCoercion) --- Flatten a type to get rid of type function applications, returning --- the new type-function-free type, and a collection of new equality --- constraints. See Note [Flattening] for more detail. --- --- Postcondition: Coercion :: Xi ~ TcType - -flatten _ _ xi@(LitTy {}) = return (xi, mkTcNomReflCo xi) - -flatten f ctxt (TyVarTy tv) - = flattenTyVar f ctxt tv - -flatten f ctxt (AppTy ty1 ty2) - = do { (xi1,co1) <- flatten f ctxt ty1 - ; (xi2,co2) <- flatten f ctxt ty2 - ; traceTcS "flatten/appty" (ppr ty1 $$ ppr ty2 $$ ppr xi1 $$ ppr co1 $$ ppr xi2 $$ ppr co2) - ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) } - -flatten f ctxt (FunTy ty1 ty2) - = do { (xi1,co1) <- flatten f ctxt ty1 - ; (xi2,co2) <- flatten f ctxt ty2 - ; return (mkFunTy xi1 xi2, mkTcFunCo Nominal co1 co2) } - -flatten f ctxt (TyConApp tc tys) - - -- Expand type synonyms that mention type families - -- on the RHS; see Note [Flattening synonyms] - | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys - , any isSynFamilyTyCon (tyConsOfType rhs) - = flatten f ctxt (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') - - -- For * a normal data type application - -- * data family application - -- * type synonym application whose RHS does not mention type families - -- See Note [Flattening synonyms] - -- we just recursively flatten the arguments. - | not (isSynFamilyTyCon tc) - = do { (xis,cos) <- flattenMany f ctxt tys - ; return (mkTyConApp tc xis, mkTcTyConAppCo Nominal tc cos) } - - -- Otherwise, it's a type function application, and we have to - -- flatten it away as well, and generate a new given equality constraint - -- between the application and a newly generated flattening skolem variable. - | otherwise - = ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated - do { (xis, cos) <- flattenMany f ctxt tys - ; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis - (cos_args, cos_rest) = splitAt (tyConArity tc) cos - -- The type function might be *over* saturated - -- in which case the remaining arguments should - -- be dealt with by AppTys - - ; (rhs_xi, ret_co) <- flattenNestedFamApp f ctxt tc xi_args - - -- Emit the flat constraints - ; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable - -- cf Trac #5655 - , mkTcAppCos (mkTcSymCo ret_co `mkTcTransCo` mkTcTyConAppCo Nominal tc cos_args) $ - cos_rest - ) - } - -flatten _f ctxt ty@(ForAllTy {}) --- We allow for-alls when, but only when, no type function --- applications inside the forall involve the bound type variables. - = do { let (tvs, rho) = splitForAllTys ty - ; (rho', co) <- flatten FMSubstOnly ctxt rho - -- Substitute only under a forall - -- See Note [Flattening under a forall] - ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } -\end{code} - -Note [Flattening synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Not expanding synonyms aggressively improves error messages, and -keeps types smaller. But we need to take care. - -Suppose - type T a = a -> a -and we want to flatten the type (T (F a)). Then we can safely flatten -the (F a) to a skolem, and return (T fsk). We don't need to expand the -synonym. This works because TcTyConAppCo can deal with synonyms -(unlike TyConAppCo), see Note [TcCoercions] in TcEvidence. - -But (Trac #8979) for - type T a = (F a, a) where F is a type function -we must expand the synonym in (say) T Int, to expose the type function -to the flattener. - - -Note [Flattening under a forall] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Under a forall, we - (a) MUST apply the inert substitution - (b) MUST NOT flatten type family applications -Hence FMSubstOnly. - -For (a) consider c ~ a, a ~ T (forall b. (b, [c]) -If we don't apply the c~a substitution to the second constraint -we won't see the occurs-check error. - -For (b) consider (a ~ forall b. F a b), we don't want to flatten -to (a ~ forall b.fsk, F a b ~ fsk) -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! - -\begin{code} -flattenNestedFamApp :: FlattenMode -> CtEvidence - -> TyCon -> [TcType] -- Exactly-saturated type function application - -> TcS (Xi, TcCoercion) -flattenNestedFamApp FMSubstOnly _ tc xi_args - = do { let fam_ty = mkTyConApp tc xi_args - ; return (fam_ty, mkTcNomReflCo fam_ty) } - -flattenNestedFamApp FMFullFlatten ctxt tc xi_args -- Eactly saturated - = do { let fam_ty = mkTyConApp tc xi_args - ; mb_ct <- lookupFlatEqn tc xi_args - ; case mb_ct of - Just (ctev, rhs_ty) - | ctev `canRewriteOrSame `ctxt -- Must allow [W]/[W] - -> -- You may think that we can just return (cc_rhs ct) but not so. - -- return (mkTcCoVarCo (ctId ct), cc_rhs ct, []) - -- The cached constraint resides in the cache so we have to flatten - -- the rhs to make sure we have applied any inert substitution to it. - -- Alternatively we could be applying the inert substitution to the - -- cache as well when we interact an equality with the inert. - -- The design choice is: do we keep the flat cache rewritten or not? - -- For now I say we don't keep it fully rewritten. - do { (rhs_xi,co) <- flatten FMFullFlatten ctev rhs_ty - ; let final_co = evTermCoercion (ctEvTerm ctev) - `mkTcTransCo` mkTcSymCo co - ; traceTcS "flatten/flat-cache hit" $ (ppr ctev $$ ppr rhs_xi $$ ppr final_co) - ; return (rhs_xi, final_co) } - - _ -> do { (ctev, rhs_xi) <- newFlattenSkolem ctxt fam_ty - ; extendFlatCache tc xi_args ctev rhs_xi - - -- The new constraint (F xi_args ~ rhs_xi) is not necessarily inert - -- (e.g. the LHS may be a redex) so we must put it in the work list - ; let ct = CFunEqCan { cc_ev = ctev - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_xi } - ; updWorkListTcS $ extendWorkListFunEq ct - - ; traceTcS "flatten/flat-cache miss" $ (ppr fam_ty $$ ppr rhs_xi $$ ppr ctev) - ; return (rhs_xi, evTermCoercion (ctEvTerm ctev)) } - } -\end{code} - -\begin{code} -flattenTyVar :: FlattenMode -> CtEvidence -> TcTyVar -> TcS (Xi, TcCoercion) --- "Flattening" a type variable means to apply the substitution to it --- The substitution is actually the union of the substitution in the TyBinds --- for the unification variables that have been unified already with the inert --- equalities, see Note [Spontaneously solved in TyBinds] in TcInteract. --- --- Postcondition: co : xi ~ tv -flattenTyVar f ctxt tv - = do { mb_yes <- flattenTyVarOuter f ctxt tv - ; case mb_yes of - Left tv' -> -- Done - do { traceTcS "flattenTyVar1" (ppr tv $$ ppr (tyVarKind tv')) - ; return (ty', mkTcNomReflCo ty') } - where - ty' = mkTyVarTy tv' - - Right (ty1, co1) -> -- Recurse - do { (ty2, co2) <- flatten f ctxt ty1 - ; traceTcS "flattenTyVar2" (ppr tv $$ ppr ty2) - ; return (ty2, co2 `mkTcTransCo` co1) } - } - -flattenTyVarOuter, flattenTyVarFinal - :: FlattenMode -> CtEvidence - -> TcTyVar - -> TcS (Either TyVar (TcType, TcCoercion)) --- Look up the tyvar in --- a) the internal MetaTyVar box --- b) the tyvar binds --- c) the inerts --- Return (Left tv') if it is not found, tv' has a properly zonked kind --- (Right (ty, co)) if found, with co :: ty ~ tv --- NB: in the latter case ty is not necessarily flattened - -flattenTyVarOuter f ctxt tv - | not (isTcTyVar tv) -- Happens when flatten under a (forall a. ty) - = flattenTyVarFinal f ctxt tv -- So ty contains refernces to the non-TcTyVar a - | otherwise - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of { - Just ty -> do { traceTcS "Following filled tyvar" (ppr tv <+> equals <+> ppr ty) - ; return (Right (ty, mkTcNomReflCo ty)) } ; - Nothing -> - - -- Try in ty_binds - do { ty_binds <- getTcSTyBindsMap - ; case lookupVarEnv ty_binds tv of { - Just (_tv,ty) -> do { traceTcS "Following bound tyvar" (ppr tv <+> equals <+> ppr ty) - ; return (Right (ty, mkTcNomReflCo ty)) } ; - -- NB: ty_binds coercions are all ReflCo, - Nothing -> - - -- Try in the inert equalities - do { ieqs <- getInertEqs - ; case lookupVarEnv ieqs tv of - Just (ct:_) -- If the first doesn't work, - | let ctev = ctEvidence ct -- the subsequent ones won't either - rhs_ty = cc_rhs ct - , ctev `canRewrite` ctxt - -> do { traceTcS "Following inert tyvar" (ppr tv <+> equals <+> ppr rhs_ty $$ ppr ctev) - ; return (Right (rhs_ty, mkTcSymCo (evTermCoercion (ctEvTerm ctev)))) } - -- NB: even if ct is Derived we are not going to - -- touch the actual coercion so we are fine. - - _other -> flattenTyVarFinal f ctxt tv - } } } } } - -flattenTyVarFinal f ctxt tv - = -- Done, but make sure the kind is zonked - do { let knd = tyVarKind tv - ; (new_knd, _kind_co) <- flatten f ctxt knd - ; return (Left (setVarType tv new_knd)) } + ContinueWith new_ev -> do { emitInsoluble (CHoleCan { cc_ev = new_ev, cc_occ = occ }) + ; stopWith new_ev "Emit insoluble hole" } + Stop ev s -> return (Stop ev s) } -- Found a cached copy; won't happen \end{code} -Note [Non-idempotent inert substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The inert substitution is not idempotent in the broad sense. It is only idempotent in -that it cannot rewrite the RHS of other inert equalities any further. An example of such -an inert substitution is: - - [G] g1 : ta8 ~ ta4 - [W] g2 : ta4 ~ a5Fj - -Observe that the wanted cannot rewrite the solved goal, despite the fact that ta4 appears on -an RHS of an equality. Now, imagine a constraint: - - [W] g3: ta8 ~ Int - -coming in. If we simply apply once the inert substitution we will get: - - [W] g3_1: ta4 ~ Int - -and because potentially ta4 is untouchable we will try to insert g3_1 in the inert set, -getting a panic since the inert only allows ONE equation per LHS type variable (as it -should). - -For this reason, when we reach to flatten a type variable, we flatten it recursively, -so that we can make sure that the inert substitution /is/ fully applied. - -Insufficient (non-recursive) rewriting was the reason for #5668. - - %************************************************************************ %* * %* Equalities @@ -732,32 +376,14 @@ Insufficient (non-recursive) rewriting was the reason for #5668. %************************************************************************ \begin{code} -canEvVarsCreated :: [CtEvidence] -> TcS StopOrContinue -canEvVarsCreated [] = return Stop - -- Add all but one to the work list - -- and return the first (if any) for futher processing -canEvVarsCreated (ev : evs) - = do { emitWorkNC evs; canEvNC ev } - -- Note the "NC": these are fresh goals, not necessarily canonical - -emitWorkNC :: [CtEvidence] -> TcS () -emitWorkNC evs - | null evs = return () - | otherwise = do { traceTcS "Emitting fresh work" (vcat (map ppr evs)) - ; updWorkListTcS (extendWorkListCts (map mk_nc evs)) } - where - mk_nc ev = mkNonCanonical ev - -------------------------- -canEqNC :: CtEvidence -> Type -> Type -> TcS StopOrContinue +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 - -> TcS StopOrContinue + -> TcS (StopOrContinue Ct) can_eq_nc ev ty1 ps_ty1 ty2 ps_ty2 = do { traceTcS "can_eq_nc" $ @@ -769,13 +395,13 @@ can_eq_nc' ev ty1 ps_ty1 ty2 ps_ty2 | Just ty1' <- tcView ty1 = can_eq_nc ev ty1' ps_ty1 ty2 ps_ty2 | Just ty2' <- tcView ty2 = can_eq_nc ev ty1 ps_ty1 ty2' ps_ty2 --- Type family on LHS or RHS take priority -can_eq_nc' ev (TyConApp fn tys) _ ty2 ps_ty2 - | isSynFamilyTyCon fn - = canEqLeafFun ev NotSwapped fn tys ty2 ps_ty2 -can_eq_nc' ev ty1 ps_ty1 (TyConApp fn tys) _ - | isSynFamilyTyCon fn - = canEqLeafFun ev IsSwapped fn tys ty1 ps_ty1 +-- Type family on LHS or RHS take priority over tyvars, +-- so that tv ~ F ty gets flattened +-- Otherwise F a ~ F a might not get solved! +can_eq_nc' ev (TyConApp fn1 tys1) _ ty2 ps_ty2 + | isSynFamilyTyCon fn1 = can_eq_fam_nc ev NotSwapped fn1 tys1 ty2 ps_ty2 +can_eq_nc' ev ty1 ps_ty1 (TyConApp fn2 tys2) _ + | isSynFamilyTyCon fn2 = can_eq_fam_nc ev IsSwapped fn2 tys2 ty1 ps_ty1 -- Type variable on LHS or RHS are next can_eq_nc' ev (TyVarTy tv1) _ ty2 ps_ty2 @@ -792,7 +418,7 @@ can_eq_nc' ev ty1@(LitTy l1) _ (LitTy l2) _ | l1 == l2 = do { when (isWanted ev) $ setEvBind (ctev_evar ev) (EvCoercion (mkTcNomReflCo ty1)) - ; return Stop } + ; stopWith ev "Equal LitTy" } -- Decomposable type constructor applications -- Synonyms and type functions (which are not decomposable) @@ -826,11 +452,11 @@ can_eq_nc' ev s1@(ForAllTy {}) _ s2@(ForAllTy {}) _ do { traceTcS "Creating implication for polytype equality" $ ppr ev ; ev_term <- deferTcSForAllEq Nominal loc (tvs1,body1) (tvs2,body2) ; setEvBind orig_ev ev_term - ; return Stop } } + ; stopWith ev "Deferred polytype equality" } } | otherwise = do { traceTcS "Ommitting decomposition of given polytype equality" $ pprEq s1 s2 -- See Note [Do not decompose given polytype equalities] - ; return Stop } + ; stopWith ev "Discard given polytype equality" } can_eq_nc' ev (AppTy s1 t1) ps_ty1 ty2 ps_ty2 = can_eq_app ev NotSwapped s1 t1 ps_ty1 ty2 ps_ty2 @@ -842,21 +468,38 @@ can_eq_nc' ev _ ps_ty1 _ ps_ty2 = canEqFailure ev ps_ty1 ps_ty2 ------------ +can_eq_fam_nc :: CtEvidence -> SwapFlag + -> TyCon -> [TcType] + -> TcType -> TcType + -> TcS (StopOrContinue Ct) +-- Canonicalise a non-canonical equality of form (F tys ~ ty) +-- or the swapped version thereof +-- Flatten both sides and go round again +can_eq_fam_nc ev swapped fn tys rhs ps_rhs + = do { let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll } + ; (xi_lhs, co_lhs) <- flattenFamApp fmode fn tys + ; mb_ct <- rewriteEqEvidence ev swapped xi_lhs rhs co_lhs (mkTcNomReflCo rhs) + ; case mb_ct of + Stop ev s -> return (Stop ev s) + ContinueWith new_ev -> can_eq_nc new_ev xi_lhs xi_lhs rhs ps_rhs } + +------------ can_eq_app, can_eq_flat_app :: CtEvidence -> SwapFlag - -> Type -> Type -> Type -- LHS (s1 t2), after and before type-synonym expansion, resp - -> Type -> Type -- RHS (ty2), after and before type-synonym expansion, resp - -> TcS StopOrContinue + -> Type -> Type -> Type -- LHS (s1 t2), after and before type-synonym expansion, resp + -> Type -> Type -- RHS (ty2), after and before type-synonym expansion, resp + -> TcS (StopOrContinue Ct) -- See Note [Canonicalising type applications] can_eq_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2 = do { traceTcS "can_eq_app 1" $ vcat [ ppr ev, ppr swapped, ppr s1, ppr t1, ppr ty2 ] - ; (xi_s1, co_s1) <- flatten FMSubstOnly ev s1 + ; let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll } + ; (xi_s1, co_s1) <- flatten fmode s1 ; traceTcS "can_eq_app 2" $ vcat [ ppr ev, ppr xi_s1 ] ; if s1 `tcEqType` xi_s1 then can_eq_flat_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2 else - do { (xi_t1, co_t1) <- flatten FMSubstOnly ev t1 + 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, -- and then crash in a call to typeKind @@ -867,8 +510,8 @@ can_eq_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2 co1 (mkTcNomReflCo ps_ty2) ; traceTcS "can_eq_app 4" $ vcat [ ppr ev, ppr xi1, ppr co1 ] ; case mb_ct of - Nothing -> return Stop - Just new_ev -> can_eq_nc new_ev xi1 xi1 ty2 ps_ty2 }} + Stop ev s -> return (Stop ev s) + ContinueWith new_ev -> can_eq_nc new_ev xi1 xi1 ty2 ps_ty2 }} -- Preconditions: s1 is already flattened -- ty2 is not a type variable, so flattening @@ -887,15 +530,15 @@ can_eq_flat_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2 xevdecomp x = let xco = evTermCoercion x in [ EvCoercion (mkTcLRCo CLeft xco) , EvCoercion (mkTcLRCo CRight xco)] - ; ctevs <- xCtEvidence ev (XEvTerm [mkTcEqPred s1 s2, mkTcEqPred t1 t2] xevcomp xevdecomp) - ; canEvVarsCreated ctevs } + ; xCtEvidence ev (XEvTerm [mkTcEqPred s1 s2, mkTcEqPred t1 t2] xevcomp xevdecomp) + ; stopWith ev "Decomposed AppTy" } ------------------------ canDecomposableTyConApp :: CtEvidence -> TyCon -> [TcType] -> TyCon -> [TcType] - -> TcS StopOrContinue + -> TcS (StopOrContinue Ct) canDecomposableTyConApp ev tc1 tys1 tc2 tys2 | tc1 /= tc2 || length tys1 /= length tys2 -- Fail straight away for better error messages @@ -906,25 +549,26 @@ canDecomposableTyConApp ev tc1 tys1 tc2 tys2 canDecomposableTyConAppOK :: CtEvidence -> TyCon -> [TcType] -> [TcType] - -> TcS StopOrContinue + -> TcS (StopOrContinue Ct) canDecomposableTyConAppOK ev tc1 tys1 tys2 = do { let xcomp xs = EvCoercion (mkTcTyConAppCo Nominal tc1 (map evTermCoercion xs)) xdecomp x = zipWith (\_ i -> EvCoercion $ mkTcNthCo i (evTermCoercion x)) tys1 [0..] xev = XEvTerm (zipWith mkTcEqPred tys1 tys2) xcomp xdecomp - ; ctevs <- xCtEvidence ev xev - ; canEvVarsCreated ctevs } + ; xCtEvidence ev xev + ; stopWith ev "Decomposed TyConApp" } -canEqFailure :: CtEvidence -> TcType -> TcType -> TcS StopOrContinue +canEqFailure :: CtEvidence -> TcType -> TcType -> TcS (StopOrContinue Ct) -- See Note [Make sure that insolubles are fully rewritten] canEqFailure ev ty1 ty2 - = do { (s1, co1) <- flatten FMSubstOnly ev ty1 - ; (s2, co2) <- flatten FMSubstOnly ev ty2 + = do { let fmode = FE { fe_ev = ev, fe_mode = FM_SubstOnly } + ; (s1, co1) <- flatten fmode ty1 + ; (s2, co2) <- flatten fmode ty2 ; mb_ct <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2 ; case mb_ct of - Just new_ev -> emitInsoluble (mkNonCanonical new_ev) - Nothing -> pprPanic "canEqFailure" (ppr ev $$ ppr ty1 $$ ppr ty2) - ; return Stop } + 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] @@ -986,163 +630,56 @@ As this point we have an insoluble constraint, like Int~Bool. class constraint. -Note [Canonical ordering for equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Implemented as (<+=) below: - - - Type function applications always come before anything else. - - Variables always come before non-variables (other than type - function applications). - -Note that we don't need to unfold type synonyms on the RHS to check -the ordering; that is, in the rules above it's OK to consider only -whether something is *syntactically* a type function application or -not. To illustrate why this is OK, suppose we have an equality of the -form 'tv ~ S a b c', where S is a type synonym which expands to a -top-level application of the type function F, something like - - type S a b c = F d e - -Then to canonicalize 'tv ~ S a b c' we flatten the RHS, and since S's -expansion contains type function applications the flattener will do -the expansion and then generate a skolem variable for the type -function application, so we end up with something like this: - - tv ~ x - F d e ~ x - -where x is the skolem variable. This is one extra equation than -absolutely necessary (we could have gotten away with just 'F d e ~ tv' -if we had noticed that S expanded to a top-level type function -application and flipped it around in the first place) but this way -keeps the code simpler. - -Unlike the OutsideIn(X) draft of May 7, 2010, we do not care about the -ordering of tv ~ tv constraints. There are several reasons why we -might: - - (1) In order to be able to extract a substitution that doesn't - mention untouchable variables after we are done solving, we might - prefer to put touchable variables on the left. However, in and - of itself this isn't necessary; we can always re-orient equality - constraints at the end if necessary when extracting a substitution. - - (2) To ensure termination we might think it necessary to put - variables in lexicographic order. However, this isn't actually - necessary as outlined below. - -While building up an inert set of canonical constraints, we maintain -the invariant that the equality constraints in the inert set form an -acyclic rewrite system when viewed as L-R rewrite rules. Moreover, -the given constraints form an idempotent substitution (i.e. none of -the variables on the LHS occur in any of the RHS's, and type functions -never show up in the RHS at all), the wanted constraints also form an -idempotent substitution, and finally the LHS of a given constraint -never shows up on the RHS of a wanted constraint. There may, however, -be a wanted LHS that shows up in a given RHS, since we do not rewrite -given constraints with wanted constraints. - -Suppose we have an inert constraint set - - - tg_1 ~ xig_1 -- givens - tg_2 ~ xig_2 - ... - tw_1 ~ xiw_1 -- wanteds - tw_2 ~ xiw_2 - ... - -where each t_i can be either a type variable or a type function -application. Now suppose we take a new canonical equality constraint, -t' ~ xi' (note among other things this means t' does not occur in xi') -and try to react it with the existing inert set. We show by induction -on the number of t_i which occur in t' ~ xi' that this process will -terminate. - -There are several ways t' ~ xi' could react with an existing constraint: - -TODO: finish this proof. The below was for the case where the entire -inert set is an idempotent subustitution... - -(b) We could have t' = t_j for some j. Then we obtain the new - equality xi_j ~ xi'; note that neither xi_j or xi' contain t_j. We - now canonicalize the new equality, which may involve decomposing it - into several canonical equalities, and recurse on these. However, - none of the new equalities will contain t_j, so they have fewer - occurrences of the t_i than the original equation. - -(a) We could have t_j occurring in xi' for some j, with t' /= - t_j. Then we substitute xi_j for t_j in xi' and continue. However, - since none of the t_i occur in xi_j, we have decreased the - number of t_i that occur in xi', since we eliminated t_j and did not - introduce any new ones. - \begin{code} -canEqLeafFun :: CtEvidence - -> SwapFlag +canCFunEqCan :: CtEvidence -> TyCon -> [TcType] -- LHS - -> TcType -> TcType -- RHS - -> TcS StopOrContinue -canEqLeafFun ev swapped fn tys1 ty2 ps_ty2 - | length tys1 > tyConArity fn - = -- Over-saturated type function on LHS: - -- flatten LHS, leaving an AppTy, and go around again - do { (xi1, co1) <- flatten FMFullFlatten ev (mkTyConApp fn tys1) - ; mb <- rewriteEqEvidence ev swapped xi1 ps_ty2 - co1 (mkTcNomReflCo ps_ty2) - ; case mb of - Nothing -> return Stop - Just new_ev -> can_eq_nc new_ev xi1 xi1 ty2 ps_ty2 } - - | otherwise - = -- ev :: F tys1 ~ ty2, if not swapped - -- ev :: ty2 ~ F tys1, if swapped - ASSERT( length tys1 == tyConArity fn ) - -- Type functions are never under-saturated - -- Previous equation checks for over-saturation - do { traceTcS "canEqLeafFun" $ pprEq (mkTyConApp fn tys1) ps_ty2 - - -- Flatten type function arguments - -- cos1 :: xis1 ~ tys1 - -- co2 :: xi2 ~ ty2 - ; (xis1,cos1) <- flattenMany FMFullFlatten ev tys1 - ; (xi2, co2) <- flatten FMFullFlatten ev ps_ty2 - - ; let fam_head = mkTyConApp fn xis1 - co1 = mkTcTyConAppCo Nominal fn cos1 - ; mb <- rewriteEqEvidence ev swapped fam_head xi2 co1 co2 - - ; let k1 = typeKind fam_head - k2 = typeKind xi2 - ; case mb of - Nothing -> return Stop - Just new_ev | k1 `isSubKind` k2 - -- Establish CFunEqCan kind invariant - -> continueWith (CFunEqCan { cc_ev = new_ev, cc_fun = fn - , cc_tyargs = xis1, cc_rhs = xi2 }) - | otherwise - -> checkKind new_ev fam_head k1 xi2 k2 } + -> TcTyVar -- RHS + -> TcS (StopOrContinue Ct) +-- ^ 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 + = do { let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll } + ; (tys', cos) <- flattenMany fmode tys + -- cos :: tys' ~ tys + ; let lhs_co = mkTcTyConAppCo Nominal fn cos + -- :: F tys' ~ F tys + new_lhs = mkTyConApp fn tys' + fsk_ty = mkTyVarTy fsk + ; mb_ev <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty + lhs_co (mkTcNomReflCo fsk_ty) + ; case mb_ev of { + Stop ev s -> return (Stop ev s) ; + ContinueWith ev' -> + + do { extendFlatCache fn tys' (ctEvCoercion ev', fsk) + ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn + , cc_tyargs = tys', cc_fsk = fsk }) } } } --------------------- canEqTyVar :: CtEvidence -> SwapFlag - -> TcTyVar + -> TcTyVar -> TcType -> TcType - -> TcS StopOrContinue + -> TcS (StopOrContinue Ct) -- A TyVar on LHS, but so far un-zonked canEqTyVar ev swapped tv1 ty2 ps_ty2 -- ev :: tv ~ s2 = do { traceTcS "canEqTyVar" (ppr tv1 $$ ppr ty2 $$ ppr swapped) - ; mb_yes <- flattenTyVarOuter FMFullFlatten ev tv1 + ; mb_yes <- flattenTyVarOuter ev tv1 ; case mb_yes of - Right (ty1, co1) -> -- co1 :: ty1 ~ tv1 - do { mb <- rewriteEqEvidence ev swapped ty1 ps_ty2 - co1 (mkTcNomReflCo ps_ty2) - ; traceTcS "canEqTyVar2" (vcat [ppr tv1, ppr ty2, ppr swapped, ppr ty1, - ppUnless (isDerived ev) (ppr co1)]) - ; case mb of - Nothing -> return Stop - Just new_ev -> can_eq_nc new_ev ty1 ty1 ty2 ps_ty2 } - - Left tv1' -> do { (xi2, co2) <- flatten FMFullFlatten ev ps_ty2 -- co2 :: xi2 ~ ps_ty2 + Right (ty1, co1, _) -- co1 :: ty1 ~ tv1 + -> do { mb <- rewriteEqEvidence ev swapped ty1 ps_ty2 + co1 (mkTcNomReflCo ps_ty2) + ; traceTcS "canEqTyVar2" (vcat [ppr tv1, ppr ty2, ppr swapped, ppr ty1, + ppUnless (isDerived ev) (ppr co1)]) + ; case mb of + Stop ev s -> return (Stop ev s) + ContinueWith new_ev -> can_eq_nc new_ev ty1 ty1 ty2 ps_ty2 } + + Left tv1' -> do { let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True } + -- Flatten the RHS less vigorously, to avoid gratuitous flattening + -- True <=> xi2 should not itself be a type-function application + ; (xi2, co2) <- flatten fmode ps_ty2 -- co2 :: xi2 ~ ps_ty2 -- Use ps_ty2 to preserve type synonyms if poss ; dflags <- getDynFlags ; canEqTyVar2 dflags ev swapped tv1' xi2 co2 } } @@ -1153,7 +690,7 @@ canEqTyVar2 :: DynFlags -> TcTyVar -- olhs -> TcType -- nrhs -> TcCoercion -- nrhs ~ orhs - -> TcS StopOrContinue + -> TcS (StopOrContinue Ct) -- LHS is an inert type variable, -- and RHS is fully rewritten, but with type synonyms -- preserved as much as possible @@ -1171,87 +708,128 @@ canEqTyVar2 dflags ev swapped tv1 xi2 co2 ; let k1 = tyVarKind tv1 k2 = typeKind xi2' ; case mb of - Nothing -> return Stop - Just new_ev | k2 `isSubKind` k1 - -- Establish CTyEqCan kind invariant - -- Reorientation has done its best, but the kinds might - -- simply be incompatible - -> continueWith (CTyEqCan { cc_ev = new_ev - , cc_tyvar = tv1, cc_rhs = xi2' }) - | otherwise - -> checkKind new_ev xi1 k1 xi2' k2 } + Stop ev s -> return (Stop ev s) + ContinueWith new_ev + | k2 `isSubKind` k1 + -- Establish CTyEqCan kind invariant + -- Reorientation has done its best, but the kinds might + -- simply be incompatible + -> continueWith (CTyEqCan { cc_ev = new_ev + , cc_tyvar = tv1, cc_rhs = xi2' }) + | otherwise + -> incompatibleKind new_ev xi1 k1 xi2' k2 } | otherwise -- Occurs check error = do { mb <- rewriteEqEvidence ev swapped xi1 xi2 co1 co2 ; case mb of - Nothing -> return () - Just new_ev -> emitInsoluble (mkNonCanonical new_ev) - -- If we have a ~ [a], it is not canonical, and in particular - -- we don't want to rewrite existing inerts with it, otherwise - -- we'd risk divergence in the constraint solver - ; return Stop } + Stop ev s -> return (Stop ev s) + ContinueWith new_ev -> do { emitInsoluble (mkNonCanonical new_ev) + -- If we have a ~ [a], it is not canonical, and in particular + -- we don't want to rewrite existing inerts with it, otherwise + -- we'd risk divergence in the constraint solver + ; stopWith new_ev "Occurs check" } } where xi1 = mkTyVarTy tv1 co1 = mkTcNomReflCo xi1 -canEqTyVarTyVar :: CtEvidence -- tv1 ~ orhs (or orhs ~ tv1, if swapped) + +canEqTyVarTyVar :: CtEvidence -- tv1 ~ orhs (or orhs ~ tv1, if swapped) -> SwapFlag - -> TyVar -> TyVar -- tv2, tv2 - -> TcCoercion -- tv2 ~ orhs - -> TcS StopOrContinue + -> TcTyVar -> TcTyVar -- tv2, tv2 + -> TcCoercion -- tv2 ~ orhs + -> TcS (StopOrContinue Ct) -- Both LHS and RHS rewrote to a type variable, +-- If swapped = NotSwapped, then +-- rw_orhs = tv1, rw_olhs = orhs +-- rw_nlhs = tv2, rw_nrhs = xi1 +-- See Note [Canonical orientation for tyvar/tyvar equality constraints] canEqTyVarTyVar ev swapped tv1 tv2 co2 | tv1 == tv2 = do { when (isWanted ev) $ ASSERT( tcCoercionRole co2 == Nominal ) setEvBind (ctev_evar ev) (EvCoercion (maybeSym swapped co2)) - ; return Stop } - - | reorient_me -- See note [Canonical ordering for equality constraints]. - -- True => the kinds are compatible, - -- so no need for further sub-kind check - -- If swapped = NotSwapped, then - -- rw_orhs = tv1, rw_olhs = orhs - -- rw_nlhs = tv2, rw_nrhs = xi1 - = do { mb <- rewriteEqEvidence ev (flipSwap swapped) xi2 xi1 - co2 (mkTcNomReflCo xi1) - ; case mb of - Nothing -> return Stop - Just new_ev -> continueWith (CTyEqCan { cc_ev = new_ev - , cc_tyvar = tv2, cc_rhs = xi1 }) } - - | otherwise - = do { mb <- rewriteEqEvidence ev swapped xi1 xi2 - (mkTcNomReflCo xi1) co2 - ; case mb of - Nothing -> return Stop - Just new_ev | k2 `isSubKind` k1 - -> continueWith (CTyEqCan { cc_ev = new_ev - , cc_tyvar = tv1, cc_rhs = xi2 }) - | otherwise - -> checkKind new_ev xi1 k1 xi2 k2 } + ; stopWith ev "Equal tyvars" } + + | incompat_kind = incompat + | isFmvTyVar tv1 = do_fmv swapped tv1 xi1 xi2 co1 co2 + | isFmvTyVar tv2 = do_fmv (flipSwap swapped) tv2 xi2 xi1 co2 co1 + | same_kind = if swap_over then do_swap else no_swap + | k1_sub_k2 = do_swap -- Note [Kind orientation for CTyEqCan] + | otherwise = no_swap -- k2_sub_k1 where - reorient_me - | k1 `tcEqKind` k2 = tv2 `better_than` tv1 - | k1 `isSubKind` k2 = True -- Note [Kind orientation for CTyEqCan] - | otherwise = False -- in TcRnTypes - xi1 = mkTyVarTy tv1 xi2 = mkTyVarTy tv2 k1 = tyVarKind tv1 k2 = tyVarKind tv2 - - tv2 `better_than` tv1 - | isMetaTyVar tv1 = False -- Never swap a meta-tyvar - | isFlatSkolTyVar tv1 = isMetaTyVar tv2 - | otherwise = isMetaTyVar tv2 || isFlatSkolTyVar tv2 - -- Note [Eliminate flat-skols] - -checkKind :: CtEvidence -- t1~t2 - -> TcType -> TcKind - -> TcType -> TcKind -- s1~s2, flattened and zonked - -> TcS StopOrContinue + co1 = mkTcNomReflCo xi1 + k1_sub_k2 = k1 `isSubKind` k2 + k2_sub_k1 = k2 `isSubKind` k1 + same_kind = k1_sub_k2 && k2_sub_k1 + incompat_kind = not (k1_sub_k2 || k2_sub_k1) + + no_swap = canon_eq swapped tv1 xi1 xi2 co1 co2 + do_swap = canon_eq (flipSwap swapped) tv2 xi2 xi1 co2 co1 + + canon_eq swapped tv1 xi1 xi2 co1 co2 + -- ev : tv1 ~ orhs (not swapped) or orhs ~ tv1 (swapped) + -- co1 : xi1 ~ tv1 + -- co2 : xi2 ~ tv2 + = do { mb <- rewriteEqEvidence ev swapped xi1 xi2 co1 co2 + ; let mk_ct ev' = CTyEqCan { cc_ev = ev', cc_tyvar = tv1, cc_rhs = xi2 } + ; return (fmap mk_ct mb) } + + -- See Note [Orient equalities with flatten-meta-vars on the left] in TcFlatten + do_fmv swapped tv1 xi1 xi2 co1 co2 + | same_kind + = canon_eq swapped tv1 xi1 xi2 co1 co2 + | otherwise -- Presumably tv1 `subKind` tv2, which is the wrong way round + = ASSERT2( k1_sub_k2, ppr tv1 $$ ppr tv2 ) + ASSERT2( isWanted ev, ppr ev ) -- Only wanteds have flatten meta-vars + do { tv_ty <- newFlexiTcSTy (tyVarKind tv1) + ; new_ev <- newWantedEvVarNC (ctEvLoc ev) (mkTcEqPred tv_ty xi2) + ; emitWorkNC [new_ev] + ; canon_eq swapped tv1 xi1 tv_ty co1 (ctEvCoercion new_ev `mkTcTransCo` co2) } + + incompat + = do { mb <- rewriteEqEvidence ev swapped xi1 xi2 (mkTcNomReflCo xi1) co2 + ; case mb of + Stop ev s -> return (Stop ev s) + ContinueWith ev' -> incompatibleKind ev' xi1 k1 xi2 k2 } + + swap_over + -- If tv1 is touchable, swap only if tv2 is also + -- touchable and it's strictly better to update the latter + -- But see Note [Avoid unnecessary swaps] + | Just lvl1 <- metaTyVarUntouchables_maybe tv1 + = case metaTyVarUntouchables_maybe tv2 of + Nothing -> False + Just lvl2 | lvl2 `strictlyDeeperThan` lvl1 -> True + | lvl1 `strictlyDeeperThan` lvl2 -> False + | otherwise -> nicer_to_update_tv2 + + -- So tv1 is not a meta tyvar + -- If only one is a meta tyvar, put it on the left + -- This is not because it'll be solved; but becuase + -- the floating step looks for meta tyvars on the left + | isMetaTyVar tv2 = True + + -- So neither is a meta tyvar + + -- If only one is a flatten tyvar, put it on the left + -- See Note [Eliminate flat-skols] + | not (isFlattenTyVar tv1), isFlattenTyVar tv2 = True + + | otherwise = False + + nicer_to_update_tv2 + = (isSigTyVar tv1 && not (isSigTyVar tv2)) + || (isSystemName (Var.varName tv2) && not (isSystemName (Var.varName tv1))) + +incompatibleKind :: CtEvidence -- t1~t2 + -> TcType -> TcKind + -> TcType -> TcKind -- s1~s2, flattened and zonked + -> TcS (StopOrContinue Ct) -- LHS and RHS have incompatible kinds, so emit an "irreducible" constraint -- CIrredEvCan (NOT CTyEqCan or CFunEqCan) -- for the type equality; and continue with the kind equality constraint. @@ -1260,23 +838,66 @@ checkKind :: CtEvidence -- t1~t2 -- -- See Note [Equalities with incompatible kinds] -checkKind new_ev s1 k1 s2 k2 -- See Note [Equalities with incompatible kinds] +incompatibleKind new_ev s1 k1 s2 k2 -- See Note [Equalities with incompatible kinds] = ASSERT( isKind k1 && isKind k2 ) do { traceTcS "canEqLeaf: incompatible kinds" (vcat [ppr k1, ppr k2]) -- Create a derived kind-equality, and solve it - ; mw <- newDerived kind_co_loc (mkTcEqPred k1 k2) - ; case mw of - Nothing -> return () - Just kev -> emitWorkNC [kev] + ; emitNewDerived kind_co_loc (mkTcEqPred k1 k2) -- Put the not-currently-soluble thing into the inert set ; continueWith (CIrredEvCan { cc_ev = new_ev }) } where - loc = ctev_loc new_ev + 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 +round should be oriented in the CTyEqCan? The rules, implemented by +canEqTyVarTyVar, are these + + * If either is a flatten-meta-variables, it goes on the left. + + * If one is a strict sub-kind of the other e.g. + (alpha::?) ~ (beta::*) + orient them so RHS is a subkind of LHS. That way we will replace + 'a' with 'b', correctly narrowing the kind. + This establishes the subkind invariant of CTyEqCan. + + * Put a meta-tyvar on the left if possible + alpha[3] ~ r + + * If both are meta-tyvars, put the more touchable one (deepest level + number) on the left, so there is the best chance of unifying it + alpha[3] ~ beta[2] + + * If both are meta-tyvars and both at the same level, put a SigTv + on the right if possible + alpha[2] ~ beta[2](sig-tv) + That way, when we unify alpha := beta, we don't lose the SigTv flag. + + * Put a meta-tv with a System Name on the left if possible so it + gets eliminated (improves error messages) + + * If one is a flatten-skolem, put it on the left so that it is + substituted out Note [Elminate flat-skols] + fsk ~ a + +Note [Avoid unnecessary swaps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we swap without actually improving matters, we can get an infnite loop. +Consider + work item: a ~ b + inert item: b ~ c +We canonicalise the work-time to (a ~ c). If we then swap it before +aeding to the inert set, we'll add (c ~ a), and therefore kick out the +inert guy, so we get + new work item: b ~ c + inert item: c ~ a +And now the cycle just repeats + Note [Eliminate flat-skols] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have [G] Num (F [a]) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 9444058048..25314b7906 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -35,16 +35,13 @@ import RnNames( extendGlobalRdrEnvRn ) import RnBinds import RnEnv import RnSource ( addTcgDUs ) -import HscTypes import Avail import Unify( tcUnifyTy ) -import Id( idType ) import Class import Type import Kind( isKind ) import ErrUtils -import MkId import DataCon import Maybes import RdrName @@ -147,10 +144,6 @@ data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin) -- GivenTheta ds => the exact context for the instance is supplied -- by the programmer; it is ds_theta -forgetTheta :: EarlyDerivSpec -> DerivSpec () -forgetTheta (InferTheta spec) = spec { ds_theta = () } -forgetTheta (GivenTheta spec) = spec { ds_theta = () } - earlyDSTyCon :: EarlyDerivSpec -> TyCon earlyDSTyCon (InferTheta spec) = ds_tc spec earlyDSTyCon (GivenTheta spec) = ds_tc spec @@ -364,56 +357,43 @@ tcDeriving tycl_decls inst_decls deriv_decls ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls ; traceTc "tcDeriving 1" (ppr early_specs) - -- for each type, determine the auxliary declarations that are common - -- to multiple derivations involving that type (e.g. Generic and - -- Generic1 should use the same TcGenGenerics.MetaTyCons) - ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs - - ; overlap_flag <- getOverlapFlag ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs - ; insts1 <- mapM (genInst True overlap_flag commonAuxs) given_specs + ; insts1 <- mapM genInst given_specs -- the stand-alone derived instances (@insts1@) are used when inferring -- the contexts for "deriving" clauses' instances (@infer_specs@) ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $ - inferInstanceContexts overlap_flag infer_specs + inferInstanceContexts infer_specs - ; insts2 <- mapM (genInst False overlap_flag commonAuxs) final_specs + ; insts2 <- mapM genInst final_specs ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2) ; loc <- getSrcSpanM - ; let (binds, newTyCons, famInsts, extraInstances) = - genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff)) + ; let (binds, famInsts, extraInstances) = + genAuxBinds loc (unionManyBags deriv_stuff) ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds ; dflags <- getDynFlags ; unless (isEmptyBag inst_info) $ - liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving inst_info rn_binds newTyCons famInsts)) + liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + (ddump_deriving inst_info rn_binds famInsts)) - ; let all_tycons = map ATyCon (bagToList newTyCons) - ; gbl_env <- tcExtendGlobalEnv all_tycons $ - tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $ - tcExtendLocalFamInstEnv (bagToList famInsts) $ + ; gbl_env <- tcExtendLocalFamInstEnv (bagToList famInsts) $ tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs) ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } where ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name - -> Bag TyCon -- ^ Empty data constructors - -> Bag (FamInst) -- ^ Rep type family instances + -> Bag FamInst -- ^ Rep type family instances -> SDoc - ddump_deriving inst_infos extra_binds repMetaTys repFamInsts + ddump_deriving inst_infos extra_binds repFamInsts = hang (ptext (sLit "Derived instances:")) 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) $$ ppr extra_binds) - $$ hangP "Generic representation:" ( - hangP "Generated datatypes for meta-information:" - (vcat (map ppr (bagToList repMetaTys))) - $$ hangP "Representation types:" - (vcat (map pprRepTy (bagToList repFamInsts)))) + $$ hangP "GHC.Generics representation types:" + (vcat (map pprRepTy (bagToList repFamInsts))) hangP s x = text "" $$ hang (ptext (sLit s)) 2 x @@ -424,22 +404,6 @@ pprRepTy fi@(FamInst { fi_tys = lhs }) equals <+> ppr rhs where rhs = famInstRHS fi --- As of 24 April 2012, this only shares MetaTyCons between derivations of --- Generic and Generic1; thus the types and logic are quite simple. -type CommonAuxiliary = MetaTyCons -type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type? - -commonAuxiliaries :: [DerivSpec ()] -> TcM (CommonAuxiliaries, BagDerivStuff) -commonAuxiliaries = foldM snoc ([], emptyBag) where - snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon}) - | getUnique cls `elem` [genClassKey, gen1ClassKey] = - extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm) - | otherwise = return acc - where extendComAux m -- don't run m if its already in the accumulator - | any ((rep_tycon ==) . fst) cas = return acc - | otherwise = do (ca, new_stuff) <- m - return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff) - renameDeriv :: Bool -> [InstInfo RdrName] -> Bag (LHsBind RdrName, LSig RdrName) @@ -478,21 +442,19 @@ renameDeriv is_boot inst_infos bagBinds inst_info@(InstInfo { iSpec = inst , iBinds = InstBindings { ib_binds = binds + , ib_tyvars = tyvars , ib_pragmas = sigs - , ib_extensions = exts -- only for type-checking + , ib_extensions = exts -- Only for type-checking , ib_derived = sa } }) - = -- Bring the right type variables into - -- scope (yuk), and rename the method binds - ASSERT( null sigs ) - bindLocalNamesFV (map Var.varName tyvars) $ + = ASSERT( null sigs ) + bindLocalNamesFV tyvars $ do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds ; let binds' = InstBindings { ib_binds = rn_binds - , ib_pragmas = [] - , ib_extensions = exts - , ib_derived = sa } + , ib_tyvars = tyvars + , ib_pragmas = [] + , ib_extensions = exts + , ib_derived = sa } ; return (inst_info { iBinds = binds' }, fvs) } - where - (tyvars, _) = tcSplitForAllTys (idType (instanceDFunId inst)) \end{code} Note [Newtype deriving and unused constructors] @@ -1704,11 +1666,11 @@ ordered by sorting on type varible, tv, (major key) and then class, k, \end{itemize} \begin{code} -inferInstanceContexts :: OverlapFlag -> [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType] +inferInstanceContexts :: [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType] -inferInstanceContexts _ [] = return [] +inferInstanceContexts [] = return [] -inferInstanceContexts oflag infer_specs +inferInstanceContexts infer_specs = do { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs) ; iterate_deriv 1 initial_solutions } where @@ -1734,7 +1696,7 @@ inferInstanceContexts oflag infer_specs | otherwise = do { -- Extend the inst info from the explicit instance decls -- with the current set of solutions, and simplify each RHS - inst_specs <- zipWithM (mkInstance oflag) current_solns infer_specs + inst_specs <- zipWithM newDerivClsInst current_solns infer_specs ; new_solns <- checkNoErrs $ extendLocalInstEnv inst_specs $ mapM gen_soln infer_specs @@ -1767,15 +1729,10 @@ inferInstanceContexts oflag infer_specs the_pred = mkClassPred clas inst_tys ------------------------------------------------------------------ -mkInstance :: OverlapFlag -> ThetaType -> DerivSpec theta -> TcM ClsInst -mkInstance overlap_flag theta - (DS { ds_name = dfun_name - , ds_tvs = tvs, ds_cls = clas, ds_tys = tys }) - = do { (subst, tvs') <- tcInstSkolTyVars tvs - ; return (mkLocalInstance dfun overlap_flag tvs' clas (substTys subst tys)) } - where - dfun = mkDictFunId dfun_name tvs theta clas tys - +newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst +newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode + , ds_tvs = tvs, ds_cls = clas, ds_tys = tys }) + = newClsInst overlap_mode dfun_name tvs theta clas tys extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a -- Add new locally-defined instances; don't bother to check @@ -1989,23 +1946,19 @@ the renamer. What a great hack! -- Representation tycons differ from the tycon in the instance signature in -- case of instances for indexed families. -- -genInst :: Bool -- True <=> standalone deriving - -> OverlapFlag - -> CommonAuxiliaries - -> DerivSpec ThetaType +genInst :: DerivSpec ThetaType -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name) -genInst _standalone_deriv default_oflag comauxs - spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args +genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys - , ds_overlap = overlap_mode , ds_name = dfun_name, ds_cls = clas, ds_loc = loc }) | is_newtype -- See Note [Bindings for Generalised Newtype Deriving] - = do { inst_spec <- mkInstance oflag theta spec + = do { inst_spec <- newDerivClsInst theta spec ; traceTc "genInst/is_newtype" (vcat [ppr loc, ppr clas, ppr tvs, ppr tys, ppr rhs_ty]) ; return ( InstInfo { iSpec = inst_spec , iBinds = InstBindings { ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty + , ib_tyvars = map Var.varName tvs -- Scope over bindings , ib_pragmas = [] , ib_extensions = [ Opt_ImpredicativeTypes , Opt_RankNTypes ] @@ -2015,32 +1968,30 @@ genInst _standalone_deriv default_oflag comauxs -- See Note [Newtype deriving and unused constructors] | otherwise - = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas + = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas dfun_name rep_tycon - (lookup rep_tycon comauxs) - ; inst_spec <- mkInstance oflag theta spec + ; inst_spec <- newDerivClsInst theta spec + ; traceTc "newder" (ppr inst_spec) ; let inst_info = InstInfo { iSpec = inst_spec , iBinds = InstBindings { ib_binds = meth_binds + , ib_tyvars = map Var.varName tvs , ib_pragmas = [] , ib_extensions = [] , ib_derived = True } } ; return ( inst_info, deriv_stuff, Nothing ) } where - oflag = setOverlapModeMaybe default_oflag overlap_mode rhs_ty = newTyConInstRhs rep_tycon rep_tc_args genDerivStuff :: SrcSpan -> Class -> Name -> TyCon - -> Maybe CommonAuxiliary -> TcM (LHsBinds RdrName, BagDerivStuff) -genDerivStuff loc clas dfun_name tycon comaux_maybe +genDerivStuff loc clas dfun_name tycon | let ck = classKey clas , ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic - = let gk = if ck == genClassKey then Gen0 else Gen1 + = let gk = if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One - Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst in do - (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name) + (binds, faminst) <- gen_Generic_binds gk tycon (nameModule dfun_name) return (binds, DerivFamInst faminst `consBag` emptyBag) | otherwise -- Non-monadic generators diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 7d549695d2..bcd6bfdf82 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -723,10 +723,15 @@ iDFunId info = instanceDFunId (iSpec info) data InstBindings a = InstBindings - { ib_binds :: (LHsBinds a) -- Bindings for the instance methods - , ib_pragmas :: [LSig a] -- User pragmas recorded for generating - -- specialised instances - , ib_extensions :: [ExtensionFlag] -- any extra extensions that should + { ib_tyvars :: [Name] -- Names of the tyvars from the instance head + -- that are lexically in scope in the bindings + + , ib_binds :: (LHsBinds a) -- Bindings for the instance methods + + , ib_pragmas :: [LSig a] -- User pragmas recorded for generating + -- specialised instances + + , ib_extensions :: [ExtensionFlag] -- Any extra extensions that should -- be enabled when type-checking this -- instance; needed for -- GeneralizedNewtypeDeriving diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 210bd79599..9e9e5513ba 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -40,6 +40,7 @@ import FastString import Outputable import SrcLoc import DynFlags +import StaticFlags ( opt_PprStyle_Debug ) import ListSetOps ( equivClasses ) import Data.Maybe @@ -424,14 +425,15 @@ mkErrorMsg ctxt ct msg ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) ; mkLongErrAt (tcl_loc tcl_env) msg err_info } -type UserGiven = ([EvVar], SkolemInfo, SrcSpan) +type UserGiven = ([EvVar], SkolemInfo, Bool, SrcSpan) getUserGivens :: ReportErrCtxt -> [UserGiven] -- One item for each enclosing implication getUserGivens (CEC {cec_encl = ctxt}) = reverse $ - [ (givens, info, tcl_loc env) - | Implic {ic_given = givens, ic_env = env, ic_info = info } <- ctxt + [ (givens, info, no_eqs, tcl_loc env) + | Implic { ic_given = givens, ic_env = env + , ic_no_eqs = no_eqs, ic_info = info } <- ctxt , not (null givens) ] \end{code} @@ -606,12 +608,13 @@ 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) ; mkEqErr_help dflags (ctxt {cec_tidy = env1}) (wanted_msg $$ binds_msg) ct is_oriented ty1 ty2 } where ev = ctEvidence ct - loc = ctev_loc ev + loc = ctEvLoc ev (ty1, ty2) = getEqPredTys (ctEvPred ev) mk_given :: [Implication] -> (CtLoc, SDoc) @@ -794,7 +797,8 @@ misMatchOrCND ctxt ct oriented ty1 ty2 | otherwise = couldNotDeduce givens ([mkTcEqPred ty1 ty2], orig) where - givens = getUserGivens ctxt + givens = [ given | given@(_, _, no_eqs, _) <- getUserGivens ctxt, not no_eqs] + -- Keep only UserGivens that have some equalities orig = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 } couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc @@ -809,7 +813,7 @@ pp_givens givens (g:gs) -> ppr_given (ptext (sLit "from the context")) g : map (ppr_given (ptext (sLit "or from"))) gs where - ppr_given herald (gs, skol_info, loc) + ppr_given herald (gs, skol_info, _, loc) = hang (herald <+> pprEvVarTheta gs) 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info , ptext (sLit "at") <+> ppr loc]) @@ -985,7 +989,9 @@ mkDictErr ctxt cts = ASSERT( not (null cts) ) do { inst_envs <- tcGetInstEnvs ; fam_envs <- tcGetFamInstEnvs - ; lookups <- mapM (lookup_cls_inst inst_envs) cts + ; let (ct1:_) = cts -- ct1 just for its location + min_cts = elim_superclasses cts + ; lookups <- mapM (lookup_cls_inst inst_envs) min_cts ; let (no_inst_cts, overlap_cts) = partition is_no_inst lookups -- Report definite no-instance errors, @@ -996,8 +1002,6 @@ mkDictErr ctxt cts ; (ctxt, err) <- mk_dict_err fam_envs ctxt (head (no_inst_cts ++ overlap_cts)) ; mkErrorMsg ctxt ct1 err } where - ct1:_ = elim_superclasses cts - no_givens = null (getUserGivens ctxt) is_no_inst (ct, (matches, unifiers, _)) @@ -1067,7 +1071,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) <- mapMaybe get_good_orig (cec_encl ctxt) + , (orig:origs) <- usefulContext ctxt pred = [sep [ ptext (sLit "add") <+> pprParendType pred <+> ptext (sLit "to the context of") , nest 2 $ ppr_skol orig $$ @@ -1078,11 +1082,6 @@ mk_dict_err fam_envs ctxt (ct, (matches, unifiers, safe_haskell)) ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc) ppr_skol skol_info = ppr skol_info - -- Do not suggest adding constraints to an *inferred* type signature! - get_good_orig ic = case ic_info ic of - SigSkol (InfSigCtxt {}) _ -> Nothing - origin -> Just origin - no_inst_msg | clas == coercibleClass = let (ty1, ty2) = getEqPredTys pred @@ -1139,7 +1138,7 @@ mk_dict_err fam_envs ctxt (ct, (matches, unifiers, safe_haskell)) givens = getUserGivens ctxt matching_givens = mapMaybe matchable givens - matchable (evvars,skol_info,loc) + matchable (evvars,skol_info,_,loc) = case ev_vars_matching of [] -> Nothing _ -> Just $ hang (pprTheta ev_vars_matching) @@ -1217,6 +1216,22 @@ mk_dict_err fam_envs ctxt (ct, (matches, unifiers, safe_haskell)) , ptext (sLit "is not in scope") ]) | otherwise = Nothing +usefulContext :: ReportErrCtxt -> TcPredType -> [SkolemInfo] +usefulContext ctxt pred + = go (cec_encl ctxt) + where + pred_tvs = tyVarsOfType pred + go [] = [] + go (ic : ics) + = case ic_info ic of + -- Do not suggest adding constraints to an *inferred* type signature! + SigSkol (InfSigCtxt {}) _ -> rest + info -> info : rest + where + -- Stop when the context binds a variable free in the predicate + rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] + | otherwise = go ics + show_fixes :: [SDoc] -> SDoc show_fixes [] = empty show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:") @@ -1408,7 +1423,8 @@ relevantBindings want_filtering ctxt ct <+> ppr (getSrcLoc id)))] new_seen = tvs_seen `unionVarSet` id_tvs - ; if (want_filtering && id_tvs `disjointVarSet` ct_tvs) + ; if (want_filtering && not opt_PprStyle_Debug + && id_tvs `disjointVarSet` ct_tvs) -- We want to filter out this binding anyway -- so discard it silently then go tidy_env n_left tvs_seen docs discards tc_bndrs @@ -1464,7 +1480,7 @@ solverDepthErrorTcS cnt ev tidy_pred = tidyType tidy_env pred ; failWithTcM (tidy_env, hang (msg cnt) 2 (ppr tidy_pred)) } where - loc = ctev_loc ev + loc = ctEvLoc ev depth = ctLocDepth loc value = subGoalCounterValue cnt depth msg CountConstraints = diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 29020b4cb9..487ee4f356 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -698,7 +698,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType) -- Deals with instantiation of kind variables - -- c.f. TcMType.tcInstTyVarsX + -- c.f. TcMType.tcInstTyVars mk_inst_ty subst (tv, result_inst_ty) | is_fixed_tv tv -- Same as result type = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) @@ -706,7 +706,8 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty = do { new_ty <- newFlexiTyVarTy (TcType.substTy subst (tyVarKind tv)) ; return (extendTvSubst subst tv new_ty, new_ty) } - ; (_, result_inst_tys, result_subst) <- tcInstTyVars con1_tvs + ; (result_subst, con1_tvs') <- tcInstTyVars con1_tvs + ; let result_inst_tys = mkTyVarTys con1_tvs' ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst (con1_tvs `zip` result_inst_tys) @@ -734,7 +735,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty -- Phew! ; return $ mkHsWrapCo co_res $ RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' - relevant_cons scrut_inst_tys result_inst_tys } + relevant_cons scrut_inst_tys result_inst_tys } where upd_fld_names = hsRecFields rbinds @@ -1111,11 +1112,12 @@ instantiateOuter orig id = return (HsVar id, tau) | otherwise - = do { (_, tys, subst) <- tcInstTyVars tvs - ; doStupidChecks id tys - ; let theta' = substTheta subst theta - ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta')) - ; wrap <- instCall orig tys theta' + = do { (subst, tvs') <- tcInstTyVars tvs + ; let tys' = mkTyVarTys tvs' + theta' = substTheta subst theta + ; doStupidChecks id tys' + ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys' $$ ppr theta')) + ; wrap <- instCall orig tys' theta' ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) } where (tvs, theta, tau) = tcSplitSigmaTy (idType id) diff --git a/compiler/typecheck/TcFlatten.lhs b/compiler/typecheck/TcFlatten.lhs new file mode 100644 index 0000000000..02783a9f08 --- /dev/null +++ b/compiler/typecheck/TcFlatten.lhs @@ -0,0 +1,1147 @@ +\begin{code} +{-# LANGUAGE CPP #-} + +module TcFlatten( + FlattenEnv(..), FlattenMode(..), + flatten, flattenMany, flattenFamApp, flattenTyVarOuter, + unflatten, + eqCanRewrite, canRewriteOrSame + ) where + +#include "HsVersions.h" + +import TcRnTypes +import TcType +import Type +import TcEvidence +import TyCon +import TypeRep +import Kind( isSubKind ) +import Var +import VarEnv +import Outputable +import VarSet +import TcSMonad as TcS +import DynFlags( DynFlags ) + +import Util +import Bag +import FastString +import Control.Monad( when ) +\end{code} + + +Note [The flattening story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A CFunEqCan is either of form + [G] <F xis> : F xis ~ fsk -- fsk is a FlatSkol + [W] x : F xis ~ fmv -- fmv is a unification variable, + -- but untouchable, + -- with MetaInfo = FlatMetaTv + where + x is the witness variable + fsk/fmv is a flatten skolem + xis are function-free + CFunEqCans are always [Wanted], or [Given], never [Derived] + + fmv untouchable just means that in a CTyVarEq, say, + fmv ~ Int + we do NOT unify fmv. + +* KEY INSIGHTS: + + - A given flatten-skolem, fsk, is known a-priori to be equal to + F xis (the LHS), with <F xis> evidence + + - A unification flatten-skolem, fmv, stands for the as-yet-unknown + type to which (F xis) will eventually reduce + +* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2 + then xis1 /= xis2 + i.e. at most one CFunEqCan with a particular LHS + +* Each canonical CFunEqCan x : F xis ~ fsk/fmv has its own + distinct evidence variable x and flatten-skolem fsk/fmv. + Why? We make a fresh fsk/fmv when the constraint is born; + and we never rewrite the RHS of a CFunEqCan. + +* Function applications can occur in the RHS of a CTyEqCan. No reason + not allow this, and it reduces the amount of flattening that must occur. + +* Flattening a type (F xis): + - If we are flattening in a Wanted/Derived constraint + then create new [W] x : F xis ~ fmv + else create new [G] x : F xis ~ fsk + with fresh evidence variable x and flatten-skolem fsk/fmv + + - Add it to the work list + + - Replace (F xis) with fsk/fmv in the type you are flattening + + - You can also add the CFunEqCan to the "flat cache", which + simply keeps track of all the function applications you + have flattened. + + - If (F xis) is in the cache already, just + use its fsk/fmv and evidence x, and emit nothing. + + - No need to substitute in the flat-cache. It's not the end + of the world if we start with, say (F alpha ~ fmv1) and + (F Int ~ fmv2) and then find alpha := Int. Athat will + simply give rise to fmv1 := fmv2 via [Interacting rule] below + +* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv + - Flatten xis (to substitute any tyvars; there are already no functions) + cos :: xis ~ flat_xis + - New wanted x2 :: F flat_xis ~ fsk/fmv + - Add new wanted to flat cache + - Discharge x = F cos ; x2 + +* Unification flatten-skolems, fmv, ONLY get unified when either + a) The CFunEqCan takes a step, using an axiom + b) During un-flattening + They are never unified in any other form of equality. + For example [W] ffmv ~ Int is stuck; it does not unify with fmv. + +* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan. + That would destroy the invariant about the shape of a CFunEqCan, + and it would risk wanted/wanted interactions. The only way we + learn information about fsk is when the CFunEqCan takes a step. + + However we *do* substitute in the LHS of a CFunEqCan (else it + would never get to fire!) + +* [Interacting rule] + (inert) [W] x1 : F tys ~ fmv1 + (work item) [W] x2 : F tys ~ fmv2 + Just solve one from the other: + x2 := x1 + fmv2 := fmv1 + This just unites the two fsks into one. + Always solve given from wanted if poss. + +* [Firing rule: wanteds] + (work item) [W] x : F tys ~ fmv + instantiate axiom: ax_co : F tys ~ rhs + + Dischard fmv: + fmv := alpha + x := ax_co ; sym x2 + [W] x2 : alpha ~ rhs (Non-canonical) + discharging the work item. This is the way that fmv's get + unified; even though they are "untouchable". + + NB: this deals with the case where fmv appears in xi, which can + happen; it just happens through the non-canonical stuff + + Possible short cut (shortCutReduction) if rhs = G rhs_tys, + where G is a type function. Then + - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis) + - Add G rhs_xis ~ fmv to flat cache + - New wanted [W] x2 : G rhs_xis ~ fmv + - Discharge x := co ; G cos ; x2 + +* [Firing rule: givens] + (work item) [G] g : F tys ~ fsk + instantiate axiom: co : F tys ~ rhs + + Now add non-canonical (since rhs is not flat) + [G] (sym g ; co) : fsk ~ rhs + + Short cut (shortCutReduction) for when rhs = G rhs_tys and G is a type function + [G] (co ; g) : G tys ~ fsk + But need to flatten tys: flat_cos : tys ~ flat_tys + [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk + + +Why given-fsks, alone, doesn't work +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Could we get away with only flatten meta-tyvars, with no flatten-skolems? No. + + [W] w : alpha ~ [F alpha Int] + +---> flatten + w = ...w'... + [W] w' : alpha ~ [fsk] + [G] <F alpha Int> : F alpha Int ~ fsk + +--> unify (no occurs check) + alpha := [fsk] + +But since fsk = F alpha Int, this is really an occurs check error. If +that is all we know about alpha, we will succeed in constraint +solving, producing a program with an infinite type. + +Even if we did finally get (g : fsk ~ Boo)l by solving (F alpha Int ~ fsk) +using axiom, zonking would not see it, so (x::alpha) sitting in the +tree will get zonked to an infinite type. (Zonking always only does +refl stuff.) + +Why flatten-meta-vars, alone doesn't work +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Look at Simple13, with unification-fmvs only + + [G] g : a ~ [F a] + +---> Flatten given + g' = g;[x] + [G] g' : a ~ [fmv] + [W] x : F a ~ fmv + +--> subst a in x + x = F g' ; x2 + [W] x2 : F [fmv] ~ fmv + +And now we have an evidence cycle between g' and x! + +If we used a given instead (ie current story) + + [G] g : a ~ [F a] + +---> Flatten given + g' = g;[x] + [G] g' : a ~ [fsk] + [G] <F a> : F a ~ fsk + +---> Substitute for a + [G] g' : a ~ [fsk] + [G] F (sym g'); <F a> : F [fsk] ~ fsk + + +Why is it right to treat fmv's differently to ordinary unification vars? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + f :: forall a. a -> a -> Bool + g :: F Int -> F Int -> Bool + +Consider + f (x:Int) (y:Bool) +This gives alpha~Int, alpha~Bool. There is an inconsistency, +but really only one error. SherLoc may tell you which location +is most likely, based on other occurrences of alpha. + +Consider + g (x:Int) (y:Bool) +Here we get (F Int ~ Int, F Int ~ Bool), which flattens to + (fmv ~ Int, fmv ~ Bool) +But there are really TWO separate errors. We must not complain +about Int~Bool. Moreover these two errors could arise in entirely +unrelated parts of the code. (In the alpha case, there must be +*some* connection (eg v:alpha in common envt).) + +Note [Orient equalities with flatten-meta-vars on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This example comes from IndTypesPerfMerge + +From the ambiguity check for + f :: (F a ~ a) => a +we get: + [G] F a ~ a + [W] F alpha ~ alpha, alpha ~ a + + From Givens we get + [G] F a ~ fsk, fsk ~ a + + Now if we flatten we get + [W] alpha ~ fmv, F alpha ~ fmv, alpha ~ a + + Now, processing the first one first, choosing alpha := fmv + [W] F fmv ~ fmv, fmv ~ a + + And now we are stuck. We must either *unify* fmv := a, or + use the fmv ~ a to rewrite F fmv ~ fmv, so we can make it + meet up with the given F a ~ blah. + +Solution: always put fmvs on the left, so we get + [W] fmv ~ alpha, F alpha ~ fmv, alpha ~ a + The point is that fmvs are very uninformative, so doing alpha := fmv + is a bad idea. We want to use other constraints on alpha first. + + +Note [Derived constraints from wanted CTyEqCans] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is this type ambiguous: (Foo e ~ Maybe e) => Foo e + (indexed-types/should_fail/T4093a) + + [G] Foo e ~ Maybe e + [W] Foo e ~ Foo ee -- ee is a unification variable + [W] Foo ee ~ Maybe ee) +--- + [G] Foo e ~ fsk + [G] fsk ~ Maybe e + + [W] Foo e ~ fmv1 + [W] Foo ee ~ fmv2 + [W] fmv1 ~ fmv2 + [W] fmv2 ~ Maybe ee + +---> fmv1 := fsk by matching LHSs + [W] Foo ee ~ fmv2 + [W] fsk ~ fmv2 + [W] fmv2 ~ Maybe ee + +---> + [W] Foo ee ~ fmv2 + [W] fmv2 ~ Maybe e + [W] fmv2 ~ Maybe ee + +Now maybe we shuld get [D] e ~ ee, and then we'd solve it entirely. +But if in a smilar situation we got [D] Int ~ Bool we'd be back +to complaining about wanted/wanted interactions. Maybe this arises +also for fundeps? + +Here's another example: + f :: [a] -> [b] -> blah + f (e1 :: F Int) (e2 :: F Int) + + we get + F Int ~ fmv + fmv ~ [alpha] + fmv ~ [beta] + + We want: alpha := beta (which might unlock something else). If we + generated [D] [alpha] ~ [beta] we'd be good here. + +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) + 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) + +But: fmv ~ alpha[0] + alpha[0] ~ fmv’ +Now we don’t see that fmv ~ fmv’, which is a problem for injectivity detection. + +Conclusion: rewrite wanteds with wanted for all untouchables. + +skol ~ untch, must re-orieint to untch ~ skol, so that we can use it to rewrite. + + + +%************************************************************************ +%* * +%* Examples + Here is a long series of examples I had to work through +%* * +%************************************************************************ + +Simple20 +~~~~~~~~ +axiom F [a] = [F a] + + [G] F [a] ~ a +--> + [G] fsk ~ a + [G] [F a] ~ fsk (nc) +--> + [G] F a ~ fsk2 + [G] fsk ~ [fsk2] + [G] fsk ~ a +--> + [G] F a ~ fsk2 + [G] a ~ [fsk2] + [G] fsk ~ a + + +----------------------------------- + +---------------------------------------- +indexed-types/should_compile/T44984 + + [W] H (F Bool) ~ H alpha + [W] alpha ~ F Bool +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 + + fmv1 ~ fmv2 + fmv0 ~ alpha + +flatten +~~~~~~~ + fmv0 := F Bool + fmv1 := H (F Bool) + fmv2 := H alpha + alpha := F Bool +plus + fmv1 ~ fmv2 + +But these two are equal under the above assumptions. +Solve by Refl. + + +--- under plan B, namely solve fmv1:=fmv2 eagerly --- + [W] H (F Bool) ~ H alpha + [W] alpha ~ F Bool +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 + + fmv1 ~ fmv2 + fmv0 ~ alpha +--> + F Bool ~ fmv0 + H fmv0 ~ fmv1 + H alpha ~ fmv2 fmv2 := fmv1 + + fmv0 ~ alpha + +flatten + fmv0 := F Bool + fmv1 := H fmv0 = H (F Bool) + retain H alpha ~ fmv2 + because fmv2 has been filled + alpha := F Bool + + +---------------------------- +indexed-types/should_failt/T4179 + +after solving + [W] fmv_1 ~ fmv_2 + [W] A3 (FCon x) ~ fmv_1 (CFunEqCan) + [W] A3 (x (aoa -> fmv_2)) ~ fmv_2 (CFunEqCan) + +---------------------------------------- +indexed-types/should_fail/T7729a + +a) [W] BasePrimMonad (Rand m) ~ m1 +b) [W] tt m1 ~ BasePrimMonad (Rand m) + +---> process (b) first + BasePrimMonad (Ramd m) ~ fmv_atH + fmv_atH ~ tt m1 + +---> now process (a) + m1 ~ s_atH ~ tt m1 -- An obscure occurs check + + +---------------------------------------- +typecheck/TcTypeNatSimple + +Original constraint + [W] x + y ~ x + alpha (non-canonical) +==> + [W] x + y ~ fmv1 (CFunEqCan) + [W] x + alpha ~ fmv2 (CFuneqCan) + [W] fmv1 ~ fmv2 (CTyEqCan) + +(sigh) + +---------------------------------------- +indexed-types/should_fail/GADTwrong1 + + [G] Const a ~ () +==> flatten + [G] fsk ~ () + work item: Const a ~ fsk +==> fire top rule + [G] fsk ~ () + work item fsk ~ () + +Surely the work item should rewrite to () ~ ()? Well, maybe not; +it'a very special case. More generally, our givens look like +F a ~ Int, where (F a) is not reducible. + + +---------------------------------------- +indexed_types/should_fail/T8227: + +Why using a different can-rewrite rule in CFunEqCan heads +does not work. + +Assuming NOT rewriting wanteds with wanteds + + Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk + [W] fmv_aBk ~ fsk_aBh + + [G] Scalar fsk_aBg ~ fsk_aBh + [G] V a ~ f_aBg + + Worklist includes [W] Scalar fmv_aBi ~ fmv_aBk + fmv_aBi, fmv_aBk are flatten unificaiton variables + + Work item: [W] V fsk_aBh ~ fmv_aBi + +Note that the inert wanteds are cyclic, because we do not rewrite +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 +[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable. + + +---------------------------------------- + +Here is a somewhat similar case: + + type family G a :: * + + blah :: (G a ~ Bool, Eq (G a)) => a -> a + blah = error "urk" + + foo x = blah x + +For foo we get + [W] Eq (G a), G a ~ Bool +Flattening + [W] G a ~ fmv, Eq fmv, fmv ~ Bool +We can't simplify away the Eq Bool unless we substitute for fmv. +Maybe that doesn't matter: we would still be left with unsolved +G a ~ Bool. + +-------------------------- +Trac #9318 has a very simple program leading to + + [W] F Int ~ Int + [W] F Int ~ Bool + +We don't want to get "Error Int~Bool". But if fmv's can rewrite +wanteds, we will + + [W] fmv ~ Int + [W] fmv ~ Bool +---> + [W] Int ~ Bool + + +%************************************************************************ +%* * +%* The main flattening functions +%* * +%************************************************************************ + +Note [Flattening] +~~~~~~~~~~~~~~~~~~~~ + flatten ty ==> (xi, cc) + where + xi has no type functions, unless they appear under ForAlls + + cc = Auxiliary given (equality) constraints constraining + the fresh type variables in xi. Evidence for these + is always the identity coercion, because internally the + fresh flattening skolem variables are actually identified + with the types they have been generated to stand in for. + +Note that it is flatten's job to flatten *every type function it sees*. +flatten is only called on *arguments* to type functions, by canEqGiven. + +Recall that in comments we use alpha[flat = ty] to represent a +flattening skolem variable alpha which has been generated to stand in +for ty. + +----- Example of flattening a constraint: ------ + flatten (List (F (G Int))) ==> (xi, cc) + where + xi = List alpha + cc = { G Int ~ beta[flat = G Int], + F beta ~ alpha[flat = F beta] } +Here + * alpha and beta are 'flattening skolem variables'. + * All the constraints in cc are 'given', and all their coercion terms + are the identity. + +NB: Flattening Skolems only occur in canonical constraints, which +are never zonked, so we don't need to worry about zonking doing +accidental unflattening. + +Note that we prefer to leave type synonyms unexpanded when possible, +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 } + +data FlattenMode -- Postcondition for all three: inert wrt the type substitution + = FM_FlattenAll -- Postcondition: function-free + + | FM_Avoid TcTyVar Bool -- Postcondition: + -- * tyvar is only mentioned in result under a rigid path + -- e.g. [a] is ok, but F a won't happen + -- * If flat_top is True, top level is not a function application + -- (but under type constructors is ok e.g. [F a]) + + | FM_SubstOnly -- See Note [Flattening under a forall] +\end{code} + +\begin{code} +-- Flatten a bunch of types all at once. +flattenMany :: FlattenEnv -> [Type] -> TcS ([Xi], [TcCoercion]) +-- Coercions :: Xi ~ Type +-- Returns True iff (no flattening happened) +-- NB: The EvVar inside the 'fe_ev :: CtEvidence' is unused, +-- we merely want (a) Given/Solved/Derived/Wanted info +-- (b) the GivenLoc/WantedLoc for when we create new evidence +flattenMany fmode tys + = -- pprTrace "flattenMany" empty $ + go tys + where go [] = return ([],[]) + go (ty:tys) = do { (xi,co) <- flatten fmode ty + ; (xis,cos) <- go tys + ; return (xi:xis,co:cos) } + +flatten :: FlattenEnv -> TcType -> TcS (Xi, TcCoercion) +-- Flatten a type to get rid of type function applications, returning +-- the new type-function-free type, and a collection of new equality +-- constraints. See Note [Flattening] for more detail. +-- +-- Postcondition: Coercion :: Xi ~ TcType + +flatten _ xi@(LitTy {}) = return (xi, mkTcNomReflCo xi) + +flatten fmode (TyVarTy tv) + = flattenTyVar fmode tv + +flatten fmode (AppTy ty1 ty2) + = do { (xi1,co1) <- flatten fmode ty1 + ; (xi2,co2) <- flatten fmode ty2 + ; traceTcS "flatten/appty" (ppr ty1 $$ ppr ty2 $$ ppr xi1 $$ ppr co1 $$ ppr xi2 $$ ppr co2) + ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) } + +flatten fmode (FunTy ty1 ty2) + = do { (xi1,co1) <- flatten fmode ty1 + ; (xi2,co2) <- flatten fmode ty2 + ; return (mkFunTy xi1 xi2, mkTcFunCo Nominal co1 co2) } + +flatten fmode (TyConApp tc tys) + + -- 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' + = case fe_mode fmode of + FM_FlattenAll | any isSynFamilyTyCon (tyConsOfType rhs) + -> flatten fmode expanded_ty + | otherwise + -> flattenTyConApp fmode tc tys + _ -> flattenTyConApp fmode tc tys + + -- Otherwise, it's a type function application, and we have to + -- flatten it away as well, and generate a new given equality constraint + -- between the application and a newly generated flattening skolem variable. + | isSynFamilyTyCon tc + = flattenFamApp fmode tc tys + + -- For * a normal data type application + -- * data family application + -- we just recursively flatten the arguments. + | otherwise -- Switch off the flat_top bit in FM_Avoid + , let fmode' = case fmode of + FE { fe_mode = FM_Avoid tv _ } + -> fmode { fe_mode = FM_Avoid tv False } + _ -> fmode + = flattenTyConApp fmode' tc tys + +flatten fmode ty@(ForAllTy {}) +-- We allow for-alls when, but only when, no type function +-- applications inside the forall involve the bound type variables. + = do { let (tvs, rho) = splitForAllTys ty + ; (rho', co) <- flatten (fmode { fe_mode = FM_SubstOnly }) rho + -- Substitute only under a forall + -- See Note [Flattening under a forall] + ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } + +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 +keeps types smaller. But we need to take care. + +Suppose + type T a = a -> a +and we want to flatten the type (T (F a)). Then we can safely flatten +the (F a) to a skolem, and return (T fsk). We don't need to expand the +synonym. This works because TcTyConAppCo can deal with synonyms +(unlike TyConAppCo), see Note [TcCoercions] in TcEvidence. + +But (Trac #8979) for + type T a = (F a, a) where F is a type function +we must expand the synonym in (say) T Int, to expose the type function +to the flattener. + + +Note [Flattening under a forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Under a forall, we + (a) MUST apply the inert substitution + (b) MUST NOT flatten type family applications +Hence FMSubstOnly. + +For (a) consider c ~ a, a ~ T (forall b. (b, [c]) +If we don't apply the c~a substitution to the second constraint +we won't see the occurs-check error. + +For (b) consider (a ~ forall b. F a b), we don't want to flatten +to (a ~ forall b.fsk, F a b ~ fsk) +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 + -- flattenExactFamApp is exactly saturated + -- flattenExactFamApp_fully lifts out the application to top level + -- Postcondition: Coercion :: Xi ~ F tys +flattenFamApp fmode tc tys -- Can be over-saturated + = ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated + -- The type function might be *over* saturated + -- in which case the remaining arguments should + -- be dealt with by AppTys + do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys + ; (xi1, co1) <- flattenExactFamApp fmode tc tys1 + -- co1 :: xi1 ~ F tys1 + ; (xis_rest, cos_rest) <- flattenMany fmode tys_rest + -- cos_res :: xis_rest ~ tys_rest + ; return ( mkAppTys xi1 xis_rest -- NB mkAppTys: rhs_xi might not be a type variable + -- cf Trac #5655 + , mkTcAppCos co1 cos_rest -- (rhs_xi :: F xis) ; (F cos :: F xis ~ F tys) + ) } + +flattenExactFamApp fmode tc tys + = case fe_mode fmode of + FM_SubstOnly -> do { (xis, cos) <- flattenMany fmode tys + ; return ( mkTyConApp tc xis + , mkTcTyConAppCo Nominal tc cos ) } + + FM_Avoid tv flat_top -> do { (xis, cos) <- flattenMany fmode tys + ; if flat_top || tv `elemVarSet` tyVarsOfTypes xis + then flattenExactFamApp_fully fmode tc tys + else return ( mkTyConApp tc xis + , mkTcTyConAppCo Nominal tc cos ) } + FM_FlattenAll -> flattenExactFamApp_fully fmode tc tys + +flattenExactFamApp_fully fmode tc tys + = do { (xis, cos) <- flattenMany (fmode { fe_mode = FM_FlattenAll })tys + ; let ret_co = mkTcTyConAppCo Nominal tc cos + -- ret_co :: F xis ~ F tys + ctxt_ev = fe_ev fmode + + ; mb_ct <- lookupFlatCache tc xis + ; case mb_ct of + Just (co, fsk) -- co :: F xis ~ fsk + | isFskTyVar fsk || not (isGiven ctxt_ev) + -> -- Usable hit in the flat-cache + -- isFskTyVar checks for a "given" in the cache + do { traceTcS "flatten/flat-cache hit" $ (ppr tc <+> ppr xis $$ ppr fsk $$ ppr co) + ; (fsk_xi, fsk_co) <- flattenTyVar fmode fsk + -- The fsk may already have been unified, so flatten it + -- fsk_co :: fsk_xi ~ fsk + ; return (fsk_xi, fsk_co `mkTcTransCo` mkTcSymCo co `mkTcTransCo` ret_co) } + -- :: fsk_xi ~ F xis + + _ -> do { let fam_ty = mkTyConApp tc xis + ; (ev, fsk) <- newFlattenSkolem ctxt_ev fam_ty + ; extendFlatCache tc xis (ctEvCoercion ev, fsk) + + -- The new constraint (F xis ~ fsk) is not necessarily inert + -- (e.g. the LHS may be a redex) so we must put it in the work list + ; let ct = CFunEqCan { cc_ev = ev + , cc_fun = tc + , cc_tyargs = xis + , cc_fsk = fsk } + ; updWorkListTcS (extendWorkListFunEq ct) + + ; 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 substitution in the TyBinds +-- for the unification variables that have been unified already with the inert +-- equalities, see Note [Spontaneously solved in TyBinds] in TcInteract. +-- +-- Postcondition: co : xi ~ tv +flattenTyVar fmode tv + = do { mb_yes <- flattenTyVarOuter (fe_ev fmode) tv + ; case mb_yes of + Left tv' -> -- Done + do { traceTcS "flattenTyVar1" (ppr tv $$ ppr (tyVarKind tv')) + ; return (ty', mkTcNomReflCo ty') } + where + ty' = mkTyVarTy tv' + + Right (ty1, co1, True) -- No need to recurse + -> do { traceTcS "flattenTyVar2" (ppr tv $$ ppr ty1) + ; return (ty1, co1) } + + Right (ty1, co1, False) -- Recurse + -> do { (ty2, co2) <- flatten fmode ty1 + ; traceTcS "flattenTyVar3" (ppr tv $$ ppr ty2) + ; return (ty2, co2 `mkTcTransCo` co1) } + } + +flattenTyVarOuter, flattenTyVarFinal + :: CtEvidence -> TcTyVar + -> TcS (Either TyVar (TcType, TcCoercion, Bool)) +-- Look up the tyvar in +-- a) the internal MetaTyVar box +-- b) the tyvar binds +-- c) the inerts +-- Return (Left tv') if it is not found, tv' has a properly zonked kind +-- (Right (ty, co, is_flat)) if found, with co :: ty ~ tv; +-- is_flat says if the result is guaranteed flattened + +flattenTyVarOuter ctxt_ev tv + | not (isTcTyVar tv) -- Happens when flatten under a (forall a. ty) + = flattenTyVarFinal ctxt_ev tv -- So ty contains refernces to the non-TcTyVar a + | otherwise + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of { + Just ty -> do { traceTcS "Following filled tyvar" (ppr tv <+> equals <+> ppr ty) + ; return (Right (ty, mkTcNomReflCo ty, False)) } ; + Nothing -> + + -- Try in the inert equalities + -- See Note [Applying the inert substitution] + do { ieqs <- getInertEqs + ; case lookupVarEnv ieqs tv of + Just (ct:_) -- If the first doesn't work, + -- the subsequent ones won't either + | CTyEqCan { cc_ev = ctev, cc_tyvar = tv, cc_rhs = rhs_ty } <- ct + , eqCanRewrite ctev ctxt_ev + -> do { traceTcS "Following inert tyvar" (ppr tv <+> equals <+> ppr rhs_ty $$ ppr ctev) + ; return (Right (rhs_ty, mkTcSymCo (ctEvCoercion ctev), True)) } + -- NB: ct is Derived then (fe_ev fmode) must be also, hence + -- we are not going to touch the returned coercion + -- so ctEvCoercion is fine. + + _other -> flattenTyVarFinal ctxt_ev tv + } } } + +flattenTyVarFinal ctxt_ev tv + = -- Done, but make sure the kind is zonked + do { let kind = tyVarKind 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 +substitution, and indeed flattenTyVarOuter applies it to the type +being flattened. It has the following properties: + + * 'a' is not in fvs(ty) + * They are *inert*; that is the eqCanRewrite relation is everywhere false + +An example of such an inert substitution is: + + [G] g1 : ta8 ~ ta4 + [W] g2 : ta4 ~ a5Fj + +If you ignored the G/W, it would not be an idempotent, but we don't ignore +it. When rewriting a constraint + ev_work :: blah +we only rewrite it with an inert constraint + ev_inert1 :: a ~ ty +if + ev_inert1 `eqCanRewrite` ev_work + +This process stops in exactly one step; that is, the RHS 'ty' cannot be further +rewritten by any other inert. Why not? If it could, we'd have + ev_inert1 :: a ~ ty[b] + ev_inert2 :: b ~ ty' +and + ev_inert2 `canRewrite` ev_work +But by the EqCanRewrite Property (see Note [eqCanRewrite]), that means +that ev_inert2 `eqCanRewrite` ev_inert1; but that means that 'b' can't +appear free in ev_inert1's RHS. + +When we *unify* a variable, which we write + alpha := ty +we must be sure we aren't creating an infinite type. But that comes +from the CTyEqCan invariant that 'a' not in fvs(ty), plus the fact that +an inert CTyEqCan is fully zonked wrt the current unification assignments. +In effect they become Givens, implemented via the side-effected substitution. + +Note [An alternative story for the inert substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used (GHC 7.8) to have this story for the inert substitution inert_eqs + + * 'a' is not in fvs(ty) + * They are *inert* in the weaker sense that there is no infinite chain of + (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc + +This means that flattening must be recursive, but it does allow + [G] a ~ [b] + [G] b ~ Maybe c + +This avoids "saturating" the Givens, which can save a modest amount of work. +It is easy to implement, in TcInteract.kick_out, by only kicking out an inert +only if (a) the work item can rewrite the inert AND + (b) the inert cannot rewrite the work item + +This is signifcantly harder to think about. It can save a LOT of work +in occurs-check cases, but we don't care about them much. Trac #5837 +is an example; all the constraints here are Givens + + [G] a ~ TF (a,Int) + --> + work TF (a,Int) ~ fsk + inert fsk ~ a + + ---> + work fsk ~ (TF a, TF Int) + inert fsk ~ a + + ---> + work a ~ (TF a, TF Int) + inert fsk ~ a + + ---> (attempting to flatten (TF a) so that it does not mention a + work TF a ~ fsk2 + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (substitute for a) + work TF (fsk2, TF Int) ~ fsk2 + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (top-level reduction, re-orient) + work fsk2 ~ (TF fsk2, TF Int) + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> (attempt to flatten (TF fsk2) to get rid of fsk2 + work TF fsk2 ~ fsk3 + work fsk2 ~ (fsk3, TF Int) + inert a ~ (fsk2, TF Int) + inert fsk ~ (fsk2, TF Int) + + ---> + work TF fsk2 ~ fsk3 + inert fsk2 ~ (fsk3, TF Int) + inert a ~ ((fsk3, TF Int), TF Int) + inert fsk ~ ((fsk3, TF Int), TF Int) + +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] +eqCanRewrite (CtGiven {}) _ = True +eqCanRewrite (CtDerived {}) (CtDerived {}) = True -- Derived can't solve wanted/given +eqCanRewrite _ _ = False + +canRewriteOrSame :: CtEvidence -> CtEvidence -> Bool +-- See Note [canRewriteOrSame] +canRewriteOrSame (CtGiven {}) _ = True +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 +tv ~ ty) can be used to rewrite ct2. + +The EqCanRewrite Property: + * For any a,b in {G,W,D} if a canRewrite b + then a canRewrite a + This is what guarantees that canonicalisation will terminate. + See Note [Applying the inert substitution] + +At the moment we don't allow Wanteds to rewrite Wanteds, because that can give +rise to very confusing type error messages. A good example is Trac #8450. +Here's another + f :: a -> Bool + f x = ( [x,'c'], [x,True] ) `seq` True +Here we get + [W] a ~ Char + [W] a ~ Bool +but we do not want to complain about Bool ~ Char! + +Note [canRewriteOrSame] +~~~~~~~~~~~~~~~~~~~~~~~ +canRewriteOrSame is similar but + * returns True for Wanted/Wanted. + * works for all kinds of constraints, not just CTyEqCans +See the call sites for explanations. + +%************************************************************************ +%* * + Unflattening +%* * +%************************************************************************ + +An unflattening example: + [W] F a ~ alpha +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 + ; untch <- getUntouchables + + ; traceTcS "Unflattening" $ braces $ + vcat [ ptext (sLit "Funeqs =") <+> pprCts funeqs + , ptext (sLit "Tv eqs =") <+> pprCts tv_eqs ] + + -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check + -- See Note [Unflatten using funeqs first] + ; funeqs <- foldrBagM (unflatten_funeq dflags) emptyCts funeqs + ; traceTcS "Unflattening 1" $ braces (pprCts funeqs) + + -- Step 2: unify the irreds, if possible + ; tv_eqs <- foldrBagM (unflatten_eq dflags untch) emptyCts tv_eqs + ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs) + + -- Step 3: fill any remaining fmvs with fresh unification variables + ; funeqs <- mapBagM finalise_funeq funeqs + ; traceTcS "Unflattening 3" $ braces (pprCts funeqs) + + -- Step 4: remove any irreds that look like ty ~ ty + ; tv_eqs <- foldrBagM finalise_eq emptyCts tv_eqs + + ; let all_flat = tv_eqs `andCts` funeqs + ; traceTcS "Unflattening done" $ braces (pprCts all_flat) + + ; return all_flat } + where + ---------------- + unflatten_funeq :: DynFlags -> Ct -> Cts -> TcS Cts + unflatten_funeq dflags ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis + , cc_fsk = fmv, cc_ev = ev }) rest + = do { -- fmv should be a flatten meta-tv; we now fix its final + -- value, and then zonking will eliminate it + filled <- tryFill dflags fmv (mkTyConApp tc xis) ev + ; return (if filled then rest else ct `consCts` rest) } + + unflatten_funeq _ other_ct _ + = pprPanic "unflatten_funeq" (ppr other_ct) + + ---------------- + finalise_funeq :: Ct -> TcS Ct + finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev }) + = do { demoteUnfilledFmv fmv + ; return (mkNonCanonical ev) } + finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct) + + ---------------- + unflatten_eq :: DynFlags -> Untouchables -> Ct -> Cts -> TcS Cts + unflatten_eq dflags untch ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs }) rest + | isFmvTyVar tv + = do { lhs_elim <- tryFill dflags tv rhs ev + ; if lhs_elim then return rest else + do { rhs_elim <- try_fill dflags untch ev rhs (mkTyVarTy tv) + ; if rhs_elim then return rest else + return (ct `consCts` rest) } } + + | otherwise + = return (ct `consCts` rest) + + unflatten_eq _ _ ct _ = pprPanic "unflatten_irred" (ppr ct) + + ---------------- + finalise_eq :: Ct -> Cts -> TcS Cts + finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs }) rest + | isFmvTyVar tv + = do { ty1 <- zonkTcTyVar tv + ; ty2 <- zonkTcType rhs + ; let is_refl = ty1 `tcEqType` ty2 + ; if is_refl then do { when (isWanted ev) $ + setEvBind (ctEvId ev) (EvCoercion $ mkTcNomReflCo rhs) + ; return rest } + else return (mkNonCanonical ev `consCts` rest) } + | otherwise + = return (mkNonCanonical ev `consCts` rest) + + finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct) + + ---------------- + try_fill dflags untch ev ty1 ty2 + | Just tv1 <- tcGetTyVar_maybe ty1 + , isTouchableOrFmv untch tv1 + , typeKind ty1 `isSubKind` tyVarKind tv1 + = tryFill dflags tv1 ty2 ev + | otherwise + = return False + +tryFill :: DynFlags -> TcTyVar -> TcType -> CtEvidence -> TcS Bool +-- (tryFill tv rhs ev) sees if 'tv' is an un-filled MetaTv +-- If so, and if tv does not appear in 'rhs', set tv := rhs +-- bind the evidence (which should be a CtWanted) to Refl<rhs> +-- and return True. Otherwise return False +tryFill dflags tv rhs ev + = ASSERT2( not (isGiven ev), ppr ev ) + do { is_filled <- isFilledMetaTyVar tv + ; if is_filled then return False else + do { rhs' <- zonkTcType rhs + ; case occurCheckExpand dflags tv rhs' of + OC_OK rhs'' -- Normal case: fill the tyvar + -> do { when (isWanted ev) $ + setEvBind (ctEvId ev) (EvCoercion (mkTcNomReflCo rhs'')) + ; setWantedTyBind tv rhs'' + ; return True } + + _ -> -- Occurs check + return False } } +\end{code} + +Note [Unflatten using funeqs first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + [W] G a ~ Int + [W] F (G a) ~ G a + +do not want to end up with + [W} F Int ~ Int +because that might actually hold! Better to end up with the two above +unsolved constraints. The flat form will be + + G a ~ fmv1 (CFunEqCan) + F fmv1 ~ fmv2 (CFunEqCan) + fmv1 ~ Int (CTyEqCan) + fmv1 ~ fmv2 (CTyEqCan) + +Flatten using the fun-eqs first. + diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index e416aafb09..fd8330176c 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -84,8 +84,7 @@ data DerivStuff -- Please add this auxiliary stuff = DerivAuxBind AuxBindSpec -- Generics - | DerivTyCon TyCon -- New data types - | DerivFamInst (FamInst) -- New type family instances + | DerivFamInst FamInst -- New type family instances -- New top-level auxiliary bindings | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB @@ -1992,7 +1991,6 @@ genAuxBindSpec loc (DerivMaxTag tycon) type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings ( Bag (LHsBind RdrName, LSig RdrName) -- Extra bindings (used by Generic only) - , Bag TyCon -- Extra top-level datatypes , Bag (FamInst) -- Extra family instances , Bag (InstInfo RdrName)) -- Extra instances @@ -2007,18 +2005,16 @@ genAuxBinds loc b = genAuxBinds' b2 where genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1) - , emptyBag, emptyBag, emptyBag) + , emptyBag, emptyBag) f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before f (DerivHsBind b) = add1 b - f (DerivTyCon t) = add2 t - f (DerivFamInst t) = add3 t - f (DerivInst i) = add4 i - - add1 x (a,b,c,d) = (x `consBag` a,b,c,d) - add2 x (a,b,c,d) = (a,x `consBag` b,c,d) - add3 x (a,b,c,d) = (a,b,x `consBag` c,d) - add4 x (a,b,c,d) = (a,b,c,x `consBag` d) + f (DerivFamInst t) = add2 t + f (DerivInst i) = add3 i + + add1 x (a,b,c) = (x `consBag` a,b,c) + add2 x (a,b,c) = (a,x `consBag` b,c) + add3 x (a,b,c) = (a,b,x `consBag` c) mk_data_type_name :: TyCon -> RdrName -- "$tT" mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index c3efb32576..582b1f38ea 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -11,10 +11,8 @@ The deriving code for the Generic class module TcGenGenerics (canDoGenerics, canDoGenerics1, GenericKind(..), - MetaTyCons, genGenericMetaTyCons, gen_Generic_binds, get_gen1_constrained_tys) where -import DynFlags import HsSyn import Type import Kind ( isKind ) @@ -24,20 +22,18 @@ import DataCon import TyCon import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) import FamInst -import Module ( Module, moduleName, moduleNameString ) +import Module ( Module, moduleName, moduleNameFS ) import IfaceEnv ( newGlobalBinder ) import Name hiding ( varName ) +import NameEnv ( lookupNameEnv ) import RdrName import BasicTypes import TysWiredIn import PrelNames -import InstEnv import TcEnv -import MkId import TcRnMonad import HscTypes import ErrUtils( Validity(..), andValid ) -import BuildTyCl import SrcLoc import Bag import VarSet (elemVarSet) @@ -45,7 +41,7 @@ import Outputable import FastString import Util -import Control.Monad (mplus,forM) +import Control.Monad ( mplus ) #include "HsVersions.h" \end{code} @@ -64,117 +60,11 @@ For the generic representation we need to generate: \end{itemize} \begin{code} -gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module +gen_Generic_binds :: GenericKind -> TyCon -> Module -> TcM (LHsBinds RdrName, FamInst) -gen_Generic_binds gk tc metaTyCons mod = do - repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod +gen_Generic_binds gk tc mod = do + repTyInsts <- tc_mkRepFamInsts gk tc mod return (mkBindsRep gk tc, repTyInsts) - -genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff) -genGenericMetaTyCons tc mod = - do loc <- getSrcSpanM - let - tc_name = tyConName tc - tc_cons = tyConDataCons tc - tc_arits = map dataConSourceArity tc_cons - - tc_occ = nameOccName tc_name - d_occ = mkGenD tc_occ - c_occ m = mkGenC tc_occ m - s_occ m n = mkGenS tc_occ m n - - mkTyCon name = ASSERT( isExternalName name ) - buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs - NonRecursive - False -- Not promotable - False -- Not GADT syntax - NoParentTyCon - - d_name <- newGlobalBinder mod d_occ loc - c_names <- forM (zip [0..] tc_cons) $ \(m,_) -> - newGlobalBinder mod (c_occ m) loc - s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n -> - newGlobalBinder mod (s_occ m n) loc - - let metaDTyCon = mkTyCon d_name - metaCTyCons = map mkTyCon c_names - metaSTyCons = map (map mkTyCon) s_names - - metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons - - -- pprTrace "rep0" (ppr rep0_tycon) $ - (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts - --- both the tycon declarations and related instances -metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff -metaTyConsToDerivStuff tc metaDts = - do loc <- getSrcSpanM - dflags <- getDynFlags - dClas <- tcLookupClass datatypeClassName - let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc - d_dfun_name <- new_dfun_name dClas tc - cClas <- tcLookupClass constructorClassName - c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ] - sClas <- tcLookupClass selectorClassName - s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc - | _ <- x ] - | x <- metaS metaDts ]) - fix_env <- getFixityEnv - - let - (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc - mk_inst clas tc dfun_name - = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys) - OverlapFlag { overlapMode = NoOverlap - , isSafeOverlap = safeLanguageOn dflags } - [] clas tys - where - tys = [mkTyConTy tc] - - -- Datatype - d_metaTycon = metaD metaDts - d_inst = mk_inst dClas d_metaTycon d_dfun_name - d_binds = InstBindings { ib_binds = dBinds - , ib_pragmas = [] - , ib_extensions = [] - , ib_derived = True } - d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds }) - - -- Constructor - c_metaTycons = metaC metaDts - c_insts = [ mk_inst cClas c ds - | (c, ds) <- myZip1 c_metaTycons c_dfun_names ] - c_binds = [ InstBindings { ib_binds = c - , ib_pragmas = [] - , ib_extensions = [] - , ib_derived = True } - | c <- cBinds ] - c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs }) - | (is,bs) <- myZip1 c_insts c_binds ] - - -- Selector - s_metaTycons = metaS metaDts - s_insts = map (map (\(s,ds) -> mk_inst sClas s ds)) - (myZip2 s_metaTycons s_dfun_names) - s_binds = [ [ InstBindings { ib_binds = s - , ib_pragmas = [] - , ib_extensions = [] - , ib_derived = True } - | s <- ss ] | ss <- sBinds ] - s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is - , iBinds = bs}))) - (myZip2 s_insts s_binds) - - myZip1 :: [a] -> [b] -> [(a,b)] - myZip1 l1 l2 = ASSERT(length l1 == length l2) zip l1 l2 - - myZip2 :: [[a]] -> [[b]] -> [[(a,b)]] - myZip2 l1 l2 = - ASSERT(and (zipWith (>=) (map length l1) (map length l2))) - [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] - - return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts) - `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst) \end{code} %************************************************************************ @@ -426,7 +316,6 @@ gk2gkDC Gen0_ _ = Gen0_DC gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d - -- Bindings for the Generic instance mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName mkBindsRep gk tycon = @@ -460,10 +349,9 @@ mkBindsRep gk tycon = tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 -> TyCon -- The type to generate representation for - -> MetaTyCons -- Metadata datatypes to refer to -> Module -- Used as the location of the new RepTy -> TcM (FamInst) -- Generated representation0 coercion -tc_mkRepFamInsts gk tycon metaDts mod = +tc_mkRepFamInsts gk tycon mod = -- Consider the example input tycon `D`, where data D a b = D_ a -- Also consider `R:DInt`, where { data family D x y :: * -> * -- ; data instance D Int a b = D_ a } @@ -496,7 +384,7 @@ tc_mkRepFamInsts gk tycon metaDts mod = Nothing -> [mkTyConApp tycon tyvar_args] -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; repTy <- tc_mkRepTy gk_ tycon metaDts + ; repTy <- tc_mkRepTy gk_ tycon -- `rep_name` is a name we generate for the synonym ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R @@ -579,16 +467,14 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 GenericKind_ -- The type to generate representation for -> TyCon - -- Metadata datatypes to refer to - -> MetaTyCons -- Generated representation0 type -> TcM Type -tc_mkRepTy gk_ tycon metaDts = +tc_mkRepTy gk_ tycon = do d1 <- tcLookupTyCon d1TyConName c1 <- tcLookupTyCon c1TyConName s1 <- tcLookupTyCon s1TyConName - nS1 <- tcLookupTyCon noSelTyConName + -- nS1 <- tcLookupTyCon noSelTyConName rec0 <- tcLookupTyCon rec0TyConName rec1 <- tcLookupTyCon rec1TyConName par1 <- tcLookupTyCon par1TyConName @@ -598,37 +484,56 @@ tc_mkRepTy gk_ tycon metaDts = times <- tcLookupTyCon prodTyConName comp <- tcLookupTyCon compTyConName - let mkSum' a b = mkTyConApp plus [a,b] + let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon + + md <- tcLookupPromDataCon metaDataDataConName + mc <- tcLookupPromDataCon metaConsDataConName + ms <- tcLookupPromDataCon metaSelDataConName + pPrefix <- tcLookupPromDataCon prefixIDataConName + pInfix <- tcLookupPromDataCon infixIDataConName + pLA <- tcLookupPromDataCon leftAssociativeDataConName + pRA <- tcLookupPromDataCon rightAssociativeDataConName + pNA <- tcLookupPromDataCon notAssociativeDataConName + + -- pJust <- tcLookupPromDataCon justDataConName + -- pNothing <- tcLookupPromDataCon nothingDataConName + + fix_env <- getFixityEnv + + let -- mkTyConApp tc = applyTys (mkTyConTy tc) + mkSum' a b = mkTyConApp plus [a,b] mkProd a b = mkTyConApp times [a,b] mkComp a b = mkTyConApp comp [a,b] mkRec0 a = mkTyConApp rec0 [a] mkRec1 a = mkTyConApp rec1 [a] mkPar1 = mkTyConTy par1 - mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)] - mkC i d a = mkTyConApp c1 [d, prod i (dataConInstOrigArgTys a $ mkTyVarTys $ tyConTyVars tycon) - (null (dataConFieldLabels a))] + mkD a = mkTyConApp d1 [ {- typeKind metaDataTy, -} metaDataTy, sumP (tyConDataCons a) ] + mkC a = mkTyConApp c1 [ {- typeKind (metaConsTy a), -} metaConsTy a + , prod (dataConInstOrigArgTys a + . mkTyVarTys . tyConTyVars $ tycon) + (dataConFieldLabels a)] -- This field has no label - mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a] + -- mkS Nothing _ a = mkTyConApp s1 [mkTyConApp ms [mkTyConTy pNothing], a] + mkS Nothing a = mkTyConApp s1 [msel, a] + where msel = mkTyConApp ms [mkStrLitTy (mkFastString "")] -- This field has a label - mkS False d a = mkTyConApp s1 [d, a] + -- mkS (Just l) _ a = mkTyConApp s1 [mkTyConApp ms [mkTyConApp pJust [selName l]], a] + mkS (Just l) a = mkTyConApp s1 [msel, a] + where msel = mkTyConApp ms [selName l] -- Sums and products are done in the same way for both Rep and Rep1 sumP [] = mkTyConTy v1 - sumP l = ASSERT(length metaCTyCons == length l) - foldBal mkSum' [ mkC i d a - | (d,(a,i)) <- zip metaCTyCons (zip l [0..])] + sumP l = foldBal mkSum' . map mkC $ l -- The Bool is True if this constructor has labelled fields - prod :: Int -> [Type] -> Bool -> Type - prod i [] _ = ASSERT(length metaSTyCons > i) - ASSERT(length (metaSTyCons !! i) == 0) - mkTyConTy u1 - prod i l b = ASSERT(length metaSTyCons > i) - ASSERT(length l == length (metaSTyCons !! i)) - foldBal mkProd [ arg d t b - | (d,t) <- zip (metaSTyCons !! i) l ] - - arg :: Type -> Type -> Bool -> Type - arg d t b = mkS b d $ case gk_ of + prod :: [Type] -> [FieldLabel] -> Type + prod [] _ = mkTyConTy u1 + prod l fl = foldBal mkProd [ ASSERT(null fl || length fl > j) + arg t (if null fl then Nothing + else Just (fl !! j)) + | (t,j) <- zip l [0..] ] + + arg :: Type -> Maybe FieldLabel -> Type + arg t fl = mkS fl $ case gk_ of -- Here we previously used Par0 if t was a type variable, but we -- realized that we can't always guarantee that we are wrapping-up -- all type variables in Par0. So we decided to stop using Par0 @@ -636,93 +541,47 @@ tc_mkRepTy gk_ tycon metaDts = Gen0_ -> mkRec0 t Gen1_ argVar -> argPar argVar t where - -- Builds argument represention for Rep1 (more complicated due to + -- Builds argument representation for Rep1 (more complicated due to -- the presence of composition). argPar argVar = argTyFold argVar $ ArgTyAlg {ata_rec0 = mkRec0, ata_par1 = mkPar1, ata_rec1 = mkRec1, ata_comp = mkComp} - - metaDTyCon = mkTyConTy (metaD metaDts) - metaCTyCons = map mkTyConTy (metaC metaDts) - metaSTyCons = map (map mkTyConTy) (metaS metaDts) - - return (mkD tycon) - --------------------------------------------------------------------------------- --- Meta-information --------------------------------------------------------------------------------- - -data MetaTyCons = MetaTyCons { -- One meta datatype per datatype - metaD :: TyCon - -- One meta datatype per constructor - , metaC :: [TyCon] - -- One meta datatype per selector per constructor - , metaS :: [[TyCon]] } - -instance Outputable MetaTyCons where - ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s)) - -metaTyCons2TyCons :: MetaTyCons -> Bag TyCon -metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s) - - --- Bindings for Datatype, Constructor, and Selector instances -mkBindsMetaD :: FixityEnv -> TyCon - -> ( LHsBinds RdrName -- Datatype instance - , [LHsBinds RdrName] -- Constructor instances - , [[LHsBinds RdrName]]) -- Selector instances -mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) - where - mkBag l = foldr1 unionBags - [ unitBag (mkRdrFunBind (L loc name) matches) - | (name, matches) <- l ] - dtBinds = mkBag ( [ (datatypeName_RDR, dtName_matches) - , (moduleName_RDR, moduleName_matches)] - ++ ifElseEmpty (isNewTyCon tycon) - [ (isNewtypeName_RDR, isNewtype_matches) ] ) - - allConBinds = map conBinds datacons - conBinds c = mkBag ( [ (conName_RDR, conName_matches c)] - ++ ifElseEmpty (dataConIsInfix c) - [ (conFixity_RDR, conFixity_matches c) ] - ++ ifElseEmpty (length (dataConFieldLabels c) > 0) - [ (conIsRecord_RDR, conIsRecord_matches c) ] - ) - - ifElseEmpty p x = if p then x else [] - fixity c = case lookupFixity fix_env (dataConName c) of - Fixity n InfixL -> buildFix n leftAssocDataCon_RDR - Fixity n InfixR -> buildFix n rightAssocDataCon_RDR - Fixity n InfixN -> buildFix n notAssocDataCon_RDR - buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc - , nlHsIntLit (toInteger n)] - - allSelBinds = map (map selBinds) datasels - selBinds s = mkBag [(selName_RDR, selName_matches s)] - - loc = srcLocSpan (getSrcLoc tycon) - mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))] - datacons = tyConDataCons tycon - datasels = map dataConFieldLabels datacons - tyConName_user = case tyConFamInst_maybe tycon of Just (ptycon, _) -> tyConName ptycon Nothing -> tyConName tycon - dtName_matches = mkStringLHS . occNameString . nameOccName - $ tyConName_user - moduleName_matches = mkStringLHS . moduleNameString . moduleName - . nameModule . tyConName $ tycon - isNewtype_matches = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] + dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user + mdName = mkStrLitTy . moduleNameFS . moduleName . nameModule . tyConName + $ tycon + isNT = mkTyConTy $ if isNewTyCon tycon + then promotedTrueDataCon + else promotedFalseDataCon + + ctName = mkStrLitTy . occNameFS . nameOccName . dataConName + ctFix c = case myLookupFixity fix_env (dataConName c) of + Just (Fixity n InfixL) -> buildFix n pLA + Just (Fixity n InfixR) -> buildFix n pRA + Just (Fixity n InfixN) -> buildFix n pNA + Nothing -> mkTyConTy pPrefix + buildFix n assoc = mkTyConApp pInfix [mkTyConTy assoc, mkNumLitTy (fromIntegral n)] - conName_matches c = mkStringLHS . occNameString . nameOccName - . dataConName $ c - conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] - conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] + myLookupFixity :: FixityEnv -> Name -> Maybe Fixity + myLookupFixity env n = case lookupNameEnv env n of + Just (FixItem _ fix) -> Just fix + Nothing -> Nothing - selName_matches s = mkStringLHS (occNameString (nameOccName s)) + isRec c = mkTyConTy $ if length (dataConFieldLabels c) > 0 + then promotedTrueDataCon + else promotedFalseDataCon + selName = mkStrLitTy . occNameFS . nameOccName + + metaDataTy = mkTyConApp md [dtName, mdName, isNT] + metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c] + -- metaSelTy s = mkTyConApp mc [ctName c, ctFix c, isRec c] + + return (mkD tycon) -------------------------------------------------------------------------------- -- Dealing with sums @@ -816,10 +675,10 @@ genLR_E i n e -------------------------------------------------------------------------------- -- Build a product expression -mkProd_E :: GenericKind_DC -- Generic or Generic1? - -> US -- Base for unique names +mkProd_E :: GenericKind_DC -- Generic or Generic1? + -> US -- Base for unique names -> [(RdrName, Type)] -- List of variables matched on the lhs and their types - -> LHsExpr RdrName -- Resulting product expression + -> LHsExpr RdrName -- Resulting product expression mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR) mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars) -- These M1s are meta-information for the constructor @@ -839,8 +698,6 @@ wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar v ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose` (nlHsVar fmap_RDR `nlHsApp` cnv)} - - -- Build a product pattern mkProd_P :: GenericKind -- Gen0 or Gen1 -> US -- Base for unique names diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index c9f0e2f870..d6f237f64f 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -425,9 +425,11 @@ tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind@(EK exp_k _ctxt) -- (NB: not zonking before looking at exp_k, to avoid left-right bias) | Just tup_sort <- tupKindSort_maybe exp_k - = tc_tuple hs_ty tup_sort hs_tys exp_kind + = traceTc "tc_hs_type tuple" (ppr hs_tys) >> + tc_tuple hs_ty tup_sort hs_tys exp_kind | otherwise - = do { (tys, kinds) <- mapAndUnzipM tc_infer_lhs_type 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 -- confusing if we give them a shared kind. Eg Trac #7410 @@ -554,7 +556,8 @@ tc_tuple hs_ty tup_sort tys exp_kind finish_tuple :: HsType Name -> TupleSort -> [TcType] -> ExpKind -> TcM TcType finish_tuple hs_ty tup_sort tau_tys exp_kind - = do { checkExpectedKind hs_ty res_kind exp_kind + = do { traceTc "finish_tuple" (ppr res_kind $$ ppr exp_kind $$ ppr exp_kind) + ; checkExpectedKind hs_ty res_kind exp_kind ; checkWiredInTyCon tycon ; return (mkTyConApp tycon tau_tys) } where diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index b986fa8c2f..d22938eba2 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -43,10 +43,7 @@ import Class import Var import VarEnv import VarSet -import CoreUnfold ( mkDFunUnfolding ) -import CoreSyn ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps ) -import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, - genericClassNames ) +import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, genericClassNames ) import Bag import BasicTypes import DynFlags @@ -64,7 +61,7 @@ import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) import Control.Monad import Maybes ( isNothing, isJust, whenIsJust ) -import Data.List ( mapAccumL ) +import Data.List ( mapAccumL, partition ) \end{code} Typechecking instance declarations is done in two passes. The first @@ -381,7 +378,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls local_infos' = concat local_infos_s -- Handwritten instances of the poly-kinded Typeable class are -- forbidden, so we handle those separately - (typeable_instances, local_infos) = splitTypeable env local_infos' + (typeable_instances, local_infos) + = partition (bad_typeable_instance env) local_infos' ; addClsInsts local_infos $ addFamInsts fam_insts $ @@ -403,7 +401,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls else tcDeriving tycl_decls inst_decls deriv_decls -- Fail if there are any handwritten instance of poly-kinded Typeable - ; mapM_ (failWithTc . instMsg) typeable_instances + ; mapM_ typeable_err typeable_instances -- Check that if the module is compiled with -XSafe, there are no -- hand written instances of old Typeable as then unsafe casts could be @@ -425,18 +423,14 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls }} where -- Separate the Typeable instances from the rest - splitTypeable _ [] = ([],[]) - splitTypeable env (i:is) = - let (typeableInsts, otherInsts) = splitTypeable env is - in if -- We will filter out instances of Typeable - (typeableClassName == is_cls_nm (iSpec i)) - -- but not those that come from Data.Typeable.Internal - && tcg_mod env /= tYPEABLE_INTERNAL - -- nor those from an .hs-boot or .hsig file - -- (deriving can't be used there) - && not (isHsBootOrSig (tcg_src env)) - then (i:typeableInsts, otherInsts) - else (typeableInsts, i:otherInsts) + bad_typeable_instance env i + = -- Class name is Typeable + typeableClassName == is_cls_nm (iSpec i) + -- but not those that come from Data.Typeable.Internal + && tcg_mod env /= tYPEABLE_INTERNAL + -- nor those from an .hs-boot or .hsig file + -- (deriving can't be used there) + && not (isHsBootOrSig (tcg_src env)) overlapCheck ty = overlapMode (is_flag $ iSpec ty) `elem` [Overlappable, Overlapping, Overlaps] @@ -446,9 +440,18 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ptext (sLit "Replace the following instance:")) 2 (pprInstanceHdr (iSpec i)) - instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; replace " - ++ "the following instance:")) - 2 (pprInstance (iSpec i)) + typeable_err i + = setSrcSpan (getSrcSpan ispec) $ + addErrTc $ hang (ptext (sLit "Typeable instances can only be derived")) + 2 (vcat [ ptext (sLit "Try") <+> quotes (ptext (sLit "deriving instance Typeable") + <+> pp_tc) + , ptext (sLit "(requires StandaloneDeriving)") ]) + where + ispec = iSpec i + pp_tc | [_kind, ty] <- is_tys ispec + , Just (tc,_) <- tcSplitTyConApp_maybe ty + = ppr tc + | otherwise = ptext (sLit "<tycon>") addClsInsts :: [InstInfo Name] -> TcM a -> TcM a addClsInsts infos thing_inside @@ -541,17 +544,11 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) -- Dfun location is that of instance *header* - ; overlap_flag <- - do defaultOverlapFlag <- getOverlapFlag - return $ setOverlapModeMaybe defaultOverlapFlag overlap_mode - ; (subst, tyvars') <- tcInstSkolTyVars tyvars - ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys - ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys) - -- Be sure to freshen those type variables, - -- so they are sure not to appear in any lookup - inst_info = InstInfo { iSpec = ispec + ; ispec <- newClsInst overlap_mode dfun_name tyvars theta clas inst_tys + ; let inst_info = InstInfo { iSpec = ispec , iBinds = InstBindings { ib_binds = binds + , ib_tyvars = map Var.varName tyvars -- Scope over bindings , ib_pragmas = uprags , ib_extensions = [] , ib_derived = False } } @@ -822,7 +819,6 @@ 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 }) @@ -840,7 +836,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; dfun_ev_vars <- newEvVars dfun_theta - ; (sc_binds, sc_ev_vars) <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta' + ; sc_ev_vars <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta' -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] @@ -848,11 +844,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Typecheck the methods ; (meth_ids, meth_binds) - <- tcExtendTyVarEnv inst_tyvars $ - -- The inst_tyvars scope over the 'where' part - -- Those tyvars are inside the dfun_id's type, which is a bit - -- bizarre, but OK so long as you realise it! - tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars + <- tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars inst_tys spec_inst_info op_items ibinds @@ -883,32 +875,20 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys -- Do not inline the dfun; instead give it a magic DFunFunfolding - -- See Note [ClassOp/DFun selection] - -- See also note [Single-method classes] - (dfun_id_w_fun, dfun_spec_prags) - | isNewTyCon class_tc - = ( dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } - , SpecPrags [] ) -- Newtype dfuns just inline unconditionally, - -- so don't attempt to specialise them + dfun_spec_prags + | isNewTyCon class_tc = SpecPrags [] + -- Newtype dfuns just inline unconditionally, + -- so don't attempt to specialise them | otherwise - = ( dfun_id `setIdUnfolding` mkDFunUnfolding (inst_tyvars ++ dfun_ev_vars) - dict_constr dfun_args - `setInlinePragma` dfunInlinePragma - , SpecPrags spec_inst_prags ) - - dfun_args :: [CoreExpr] - dfun_args = map Type inst_tys ++ - map Var sc_ev_vars ++ - map mk_meth_app meth_ids - mk_meth_app meth_id = Var meth_id `mkTyApps` inst_tv_tys `mkVarApps` dfun_ev_vars - - export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun + = SpecPrags spec_inst_prags + + export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id , abe_mono = self_dict, abe_prags = dfun_spec_prags } -- NB: see Note [SPECIALISE instance pragmas] main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] - , abs_ev_binds = sc_binds + , abs_ev_binds = emptyTcEvBinds , abs_binds = unitBag dict_bind } ; return (unitBag (L loc main_bind) `unionBags` @@ -920,22 +900,23 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ------------------------------ tcSuperClasses :: DFunId -> [TcTyVar] -> [EvVar] -> TcThetaType - -> TcM (TcEvBinds, [EvVar]) + -> TcM [EvVar] -- See Note [Silent superclass arguments] tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta + | null inst_tyvars && null dfun_ev_vars + = emitWanteds ScOrigin sc_theta + + | otherwise = do { -- Check that all superclasses can be deduced from -- the originally-specified dfun arguments - ; (sc_binds, sc_evs) <- checkConstraints InstSkol inst_tyvars orig_ev_vars $ - emitWanteds ScOrigin sc_theta + ; _ <- checkConstraints InstSkol inst_tyvars orig_ev_vars $ + emitWanteds ScOrigin sc_theta - ; if null inst_tyvars && null dfun_ev_vars - then return (sc_binds, sc_evs) - else return (emptyTcEvBinds, sc_lam_args) } + ; return (map (find dfun_ev_vars) sc_theta) } where n_silent = dfunNSilent dfun_id orig_ev_vars = drop n_silent dfun_ev_vars - sc_lam_args = map (find dfun_ev_vars) sc_theta find [] pred = pprPanic "tcInstDecl2" (ppr dfun_id $$ ppr (idType dfun_id) $$ ppr pred) find (ev:evs) pred @@ -1196,10 +1177,13 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar] tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys (spec_inst_prags, prag_fn) op_items (InstBindings { ib_binds = binds + , ib_tyvars = lexical_tvs , ib_pragmas = sigs , ib_extensions = exts , ib_derived = is_derived }) - = do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) + = tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $ + -- The lexical_tvs scope over the 'where' part + do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) ; let hs_sig_fn = mkHsSigFun sigs ; checkMinimalDefinition ; set_exts exts $ mapAndUnzipM (tc_item hs_sig_fn) op_items } diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 747eb91872..4884f1fd75 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -2,14 +2,15 @@ {-# LANGUAGE CPP #-} module TcInteract ( - solveInteractGiven, -- Solves [EvVar],GivenLoc - solveInteract, -- Solves Cts + solveFlatGivens, -- Solves [EvVar],GivenLoc + solveFlatWanteds -- Solves Cts ) where #include "HsVersions.h" import BasicTypes () import TcCanonical +import TcFlatten import VarSet import Type import Unify @@ -38,8 +39,6 @@ import TcErrors import TcSMonad import Bag -import Control.Monad ( foldM ) -import Data.Maybe ( catMaybes ) import Data.List( partition ) import VarEnv @@ -81,47 +80,76 @@ Note [Basic Simplifier Plan] If in Step 1 no such element exists, we have exceeded our context-stack depth and will simply fail. +Note [Unflatten after solving the flat wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We unflatten after solving the wc_flats of an implication, and before attempting +to float. This means that + + * The fsk/fmv flatten-skolems only survive during solveFlats. We don't + need to worry about then across successive passes over the constraint tree. + (E.g. we don't need the old ic_fsk field of an implication. + + * When floating an equality outwards, we don't need to worry about floating its + associated flattening constraints. + + * Another tricky case becomes easy: Trac #4935 + type instance F True a b = a + type instance F False a b = b + + [w] F c a b ~ gamma + (c ~ True) => a ~ gamma + (c ~ False) => b ~ gamma + + Obviously this is soluble with gamma := F c a b, and unflattening + will do exactly that after solving the flat constraints and before + attempting the implications. Before, when we were not unflattening, + we had to push Wanted funeqs in as new givens. Yuk! + + Another example that becomes easy: indexed_types/should_fail/T7786 + [W] BuriedUnder sub k Empty ~ fsk + [W] Intersect fsk inv ~ s + [w] xxx[1] ~ s + [W] forall[2] . (xxx[1] ~ Empty) + => Intersect (BuriedUnder sub k Empty) inv ~ Empty + + \begin{code} -solveInteractGiven :: CtLoc -> [TcTyVar] -> [EvVar] -> TcS (Bool, [TcTyVar]) -solveInteractGiven loc old_fsks givens +solveFlatGivens :: CtLoc -> [EvVar] -> TcS () +solveFlatGivens loc givens | null givens -- Shortcut for common case - = return (True, old_fsks) + = return () | otherwise - = do { implics1 <- solveInteract fsk_bag - - ; (no_eqs, more_fsks, implics2) <- getGivenInfo (solveInteract given_bag) - ; MASSERT( isEmptyBag implics1 && isEmptyBag implics2 ) - -- empty implics because we discard Given equalities between - -- foralls (see Note [Do not decompose given polytype equalities] - -- in TcCanonical), and those are the ones that can give - -- rise to new implications - - ; return (no_eqs, more_fsks ++ old_fsks) } + = solveFlats (listToBag (map mk_given_ct givens)) where - given_bag = listToBag [ mkNonCanonical $ CtGiven { ctev_evtm = EvId ev_id - , ctev_pred = evVarPred ev_id - , ctev_loc = loc } - | ev_id <- givens ] - - -- See Note [Given flatten-skolems] in TcSMonad - fsk_bag = listToBag [ mkNonCanonical $ CtGiven { ctev_evtm = EvCoercion (mkTcNomReflCo tv_ty) - , ctev_pred = pred - , ctev_loc = loc } - | tv <- old_fsks - , let FlatSkol fam_ty = tcTyVarDetails tv - tv_ty = mkTyVarTy tv - pred = mkTcEqPred fam_ty tv_ty - ] + mk_given_ct ev_id = mkNonCanonical (CtGiven { ctev_evtm = EvId ev_id + , ctev_pred = evVarPred ev_id + , ctev_loc = loc }) + +solveFlatWanteds :: Cts -> TcS WantedConstraints +solveFlatWanteds wanteds + = do { solveFlats wanteds + ; unsolved_implics <- getWorkListImplics + ; (tv_eqs, fun_eqs, insols, others) <- getUnsolvedInerts + ; unflattened_eqs <- unflatten tv_eqs fun_eqs + -- See Note [Unflatten after solving the flat wanteds] + + ; zonked <- zonkFlats (others `andCts` unflattened_eqs) + -- Postcondition is that the wl_flats are zonked + ; return (WC { wc_flat = zonked + , wc_insol = insols + , wc_impl = unsolved_implics }) } -- The main solver loop implements Note [Basic Simplifier Plan] --------------------------------------------------------------- -solveInteract :: Cts -> TcS (Bag Implication) +solveFlats :: Cts -> TcS () -- Returns the final InertSet in TcS -- Has no effect on work-list or residual-iplications -solveInteract cts - = {-# SCC "solveInteract" #-} - withWorkList cts $ +-- The constraints are initially examined in left-to-right order + +solveFlats cts + = {-# SCC "solveFlats" #-} do { dyn_flags <- getDynFlags + ; updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts) ; solve_loop (maxSubGoalDepth dyn_flags) } where solve_loop max_depth @@ -136,7 +164,7 @@ solveInteract cts -> do { runSolverPipeline thePipeline ct; solve_loop max_depth } } type WorkItem = Ct -type SimplifierStage = WorkItem -> TcS StopOrContinue +type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct) data SelectWorkItem = NoWorkRemaining -- No more work left (effectively we're done!) @@ -177,26 +205,27 @@ runSolverPipeline pipeline workItem ; final_is <- getTcSInerts ; case final_res of - Stop -> do { traceTcS "End solver pipeline (discharged) }" - (ptext (sLit "inerts = ") <+> ppr final_is) + Stop ev s -> do { traceFireTcS ev s + ; traceTcS "End solver pipeline (discharged) }" + (ptext (sLit "inerts =") <+> ppr final_is) ; return () } - ContinueWith ct -> do { traceFireTcS ct (ptext (sLit "Kept as inert")) + ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (ptext (sLit "Kept as inert")) ; traceTcS "End solver pipeline (not discharged) }" $ - vcat [ ptext (sLit "final_item = ") <+> ppr ct + vcat [ ptext (sLit "final_item =") <+> ppr ct , pprTvBndrs (varSetElems $ tyVarsOfCt ct) - , ptext (sLit "inerts = ") <+> ppr final_is] + , ptext (sLit "inerts =") <+> ppr final_is] ; insertInertItemTcS ct } } - where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue -> TcS StopOrContinue - run_pipeline [] res = return res - run_pipeline _ Stop = return Stop + where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct + -> TcS (StopOrContinue Ct) + run_pipeline [] res = return res + run_pipeline _ (Stop ev s) = return (Stop ev s) run_pipeline ((stg_name,stg):stgs) (ContinueWith ct) = do { traceTcS ("runStage " ++ stg_name ++ " {") (text "workitem = " <+> ppr ct) ; res <- stg ct ; traceTcS ("end stage " ++ stg_name ++ " }") empty - ; run_pipeline stgs res - } + ; run_pipeline stgs res } \end{code} Example 1: @@ -266,27 +295,21 @@ or, equivalently, type StopNowFlag = Bool -- True <=> stop after this interaction -interactWithInertsStage :: WorkItem -> TcS StopOrContinue +interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct) -- Precondition: if the workitem is a CTyEqCan then it will not be able to -- react with anything at this stage. interactWithInertsStage wi = do { inerts <- getTcSInerts ; let ics = inert_cans inerts - ; (mb_ics', stop) <- case wi of + ; case wi of CTyEqCan {} -> interactTyVarEq ics wi CFunEqCan {} -> interactFunEq ics wi CIrredEvCan {} -> interactIrred ics wi CDictCan {} -> interactDict ics wi - _ -> pprPanic "interactWithInerts" (ppr wi) + _ -> pprPanic "interactWithInerts" (ppr wi) } -- CHoleCan are put straight into inert_frozen, so never get here -- CNonCanonical have been canonicalised - ; case mb_ics' of - Just ics' -> setTcSInerts (inerts { inert_cans = ics' }) - Nothing -> return () - ; case stop of - True -> return Stop - False -> return (ContinueWith wi) } \end{code} \begin{code} @@ -336,7 +359,7 @@ solveOneFromTheOther ev_i ev_w -- we can rewrite them. We can never improve using this: -- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not -- mean that (ty1 ~ ty2) -interactIrred :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag) +interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w }) | let pred = ctEvPred ev_w @@ -346,16 +369,19 @@ interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w }) , let ctev_i = ctEvidence ct_i = ASSERT( null rest ) do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w - ; let inerts' = case inert_effect of - IRKeep -> Nothing - IRDelete -> Just (inerts { inert_irreds = others }) - IRReplace -> Just (inerts { inert_irreds = extendCts others workItem }) - ; when stop_now $ traceFireTcS workItem $ - ptext (sLit "Irred equal") <+> parens (ppr inert_effect) - ; return (inerts', stop_now) } + ; case inert_effect of + IRKeep -> return () + IRDelete -> updInertIrreds (\_ -> others) + IRReplace -> updInertIrreds (\_ -> others `snocCts` workItem) + -- These const upd's assume that solveOneFromTheOther + -- has no side effects on InertCans + ; if stop_now then + return (Stop ev_w (ptext (sLit "Irred equal") <+> parens (ppr inert_effect))) + ; else + continueWith workItem } | otherwise - = return (Nothing, False) + = continueWith workItem interactIrred _ wi = pprPanic "interactIrred" (ppr wi) \end{code} @@ -367,19 +393,19 @@ interactIrred _ wi = pprPanic "interactIrred" (ppr wi) ********************************************************************************* \begin{code} -interactDict :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag) +interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) - | let dicts = inert_dicts inerts - , Just ct_i <- findDict (inert_dicts inerts) cls tys + | Just ct_i <- findDict (inert_dicts inerts) cls tys , let ctev_i = ctEvidence ct_i = do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w - ; let inerts' = case inert_effect of - IRKeep -> Nothing - IRDelete -> Just (inerts { inert_dicts = delDict dicts cls tys }) - IRReplace -> Just (inerts { inert_dicts = addDict dicts cls tys workItem }) - ; when stop_now $ traceFireTcS workItem $ - ptext (sLit "Dict equal") <+> parens (ppr inert_effect) - ; return (inerts', stop_now) } + ; case inert_effect of + IRKeep -> return () + IRDelete -> updInertDicts $ \ ds -> delDict ds cls tys + 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 + continueWith workItem } | cls `hasKey` ipClassNameKey , isGiven ev_w @@ -389,16 +415,17 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = do { mapBagM_ (addFunDepWork workItem) (findDictsByClass (inert_dicts inerts) cls) -- Standard thing: create derived fds and keep on going. Importantly we don't -- throw workitem back in the worklist because this can cause loops (see #5236) - ; return (Nothing, False) } + ; continueWith workItem } interactDict _ wi = pprPanic "interactDict" (ppr wi) -interactGivenIP :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag) +interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct) -- Work item is Given (?x:ty) -- See Note [Shadowing of Implicit Parameters] -interactGivenIP inerts workItem@(CDictCan { cc_class = cls, cc_tyargs = tys@(ip_str:_) }) - = do { traceFireTcS workItem $ ptext (sLit "Given IP") - ; return (Just (inerts { inert_dicts = addDict filtered_dicts cls tys workItem }), True) } +interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls + , cc_tyargs = tys@(ip_str:_) }) + = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem } + ; stopWith ev "Given IP" } where dicts = inert_dicts inerts ip_dicts = findDictsByClass dicts cls @@ -417,21 +444,13 @@ addFunDepWork work_ct inert_ct = do { let fd_eqns :: [Equation CtLoc] fd_eqns = [ eqn { fd_loc = derived_loc } | eqn <- improveFromAnother inert_pred work_pred ] - ; fd_work <- rewriteWithFunDeps fd_eqns + ; rewriteWithFunDeps fd_eqns -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok -- NB: We do create FDs for given to report insoluble equations that arise -- from pairs of Givens, and also because of floating when we approximate -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs -- Also see Note [When improvement happens] - - ; traceTcS "addFuNDepWork" - (vcat [ text "inertItem =" <+> ppr inert_ct - , text "workItem =" <+> ppr work_ct - , text "fundeps =" <+> ppr fd_work ]) - - ; case fd_work of - [] -> return () - _ -> updWorkListTcS (extendWorkListEqs fd_work) } + } where work_pred = ctPred work_ct inert_pred = ctPred inert_ct @@ -499,93 +518,72 @@ I can think of two ways to fix this: ********************************************************************************* \begin{code} -interactFunEq :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag) +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 - , cc_tyargs = args, cc_rhs = rhs }) - | (CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i } : _) <- matching_inerts - , ev_i `canRewrite` ev - = do { traceTcS "interact with inerts: FunEq/FunEq" $ - vcat [ text "workItem =" <+> ppr workItem - , text "inertItem=" <+> ppr ev_i ] - ; solveFunEq ev_i rhs_i ev rhs - ; return (Nothing, True) } - - | (ev_i : _) <- [ ev_i | CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i } <- matching_inerts - , rhs_i `tcEqType` rhs -- Duplicates - , ev_i `canRewriteOrSame` ev ] - = do { when (isWanted ev) (setEvBind (ctev_evar ev) (ctEvTerm ev_i)) - ; return (Nothing, True) } - - | eq_is@(eq_i : _) <- matching_inerts - , ev `canRewrite` ctEvidence eq_i -- This is unusual - = do { let solve (CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i }) - = solveFunEq ev rhs ev_i rhs_i - solve ct = pprPanic "interactFunEq" (ppr ct) - ; mapM_ solve eq_is - ; return (Just (inerts { inert_funeqs = replaceFunEqs funeqs tc args workItem }), True) } - - | (CFunEqCan { cc_rhs = rhs_i } : _) <- matching_inerts - = -- We have F ty ~ r1, F ty ~ r2, but neither can rewrite the other; - -- for example, they might both be Derived, or both Wanted - -- So we generate a new derived equality r1~r2 - do { mb <- newDerived loc (mkTcEqPred rhs_i rhs) - ; case mb of - Just x -> updWorkListTcS (extendWorkListEq (mkNonCanonical x)) - Nothing -> return () - ; return (Nothing, False) } - - | Just ops <- isBuiltInSynFamTyCon_maybe tc - = do { let is = findFunEqsByTyCon funeqs tc - ; traceTcS "builtInCandidates: " $ ppr is - ; let interact = sfInteractInert ops args rhs - ; impMbs <- sequence - [ do mb <- newDerived (ctev_loc iev) (mkTcEqPred lhs_ty rhs_ty) - case mb of - Just x -> return $ Just $ mkNonCanonical x - Nothing -> return Nothing - | CFunEqCan { cc_tyargs = iargs - , cc_rhs = ixi - , cc_ev = iev } <- is - , Pair lhs_ty rhs_ty <- interact iargs ixi - ] - ; let imps = catMaybes impMbs - ; unless (null imps) $ updWorkListTcS (extendWorkListEqs imps) - ; return (Nothing, False) } + , cc_tyargs = args, cc_fsk = fsk }) + | Just (CFunEqCan { cc_ev = ev_i, cc_fsk = fsk_i }) <- matching_inerts + = if ev_i `canRewriteOrSame` ev + then -- Rewrite work-item using inert + do { traceTcS "reactFunEq (discharge work item):" $ + vcat [ text "workItem =" <+> ppr workItem + , text "inertItem=" <+> ppr ev_i ] + ; reactFunEq ev_i fsk_i ev fsk + ; stopWith ev "Inert rewrites work item" } + else -- Rewrite intert using work-item + do { traceTcS "reactFunEq (rewrite inert item):" $ + vcat [ text "workItem =" <+> ppr workItem + , text "inertItem=" <+> ppr ev_i ] + ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args workItem + -- Do the updInertFunEqs before the reactFunEq, so that + -- we don't kick out the inertItem as well as consuming it! + ; reactFunEq ev fsk ev_i fsk_i + ; stopWith ev "Work item rewrites inert" } + + | Just ops <- isBuiltInSynFamTyCon_maybe 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)) + (interact iargs (lookupFlattenTyVar eqs ifsk)) + do_one ct = pprPanic "interactFunEq" (ppr ct) + ; mapM_ do_one matching_funeqs + ; traceTcS "builtInCandidates 1: " $ vcat [ ptext (sLit "Candidates:") <+> ppr matching_funeqs + , ptext (sLit "TvEqs:") <+> ppr eqs ] + ; return (ContinueWith workItem) } | otherwise - = return (Nothing, False) + = return (ContinueWith workItem) where + eqs = inert_eqs inerts funeqs = inert_funeqs inerts matching_inerts = findFunEqs funeqs tc args - loc = ctev_loc ev interactFunEq _ wi = pprPanic "interactFunEq" (ppr wi) +lookupFlattenTyVar :: TyVarEnv EqualCtList -> TcTyVar -> TcType +-- ^ Look up a flatten-tyvar in the inert TyVarEqs +lookupFlattenTyVar inert_eqs ftv + = case lookupVarEnv inert_eqs ftv of + Just (CTyEqCan { cc_rhs = rhs } : _) -> rhs + _ -> mkTyVarTy ftv -solveFunEq :: CtEvidence -- From this :: F tys ~ xi1 - -> Type - -> CtEvidence -- Solve this :: F tys ~ xi2 - -> Type +reactFunEq :: CtEvidence -> TcTyVar -- From this :: F tys ~ fsk1 + -> CtEvidence -> TcTyVar -- Solve this :: F tys ~ fsk2 -> TcS () -solveFunEq from_this xi1 solve_this xi2 - = do { ctevs <- xCtEvidence solve_this xev - -- No caching! See Note [Cache-caused loops] - -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation] - - ; emitWorkNC ctevs } - where - from_this_co = evTermCoercion $ ctEvTerm from_this - - xev = XEvTerm [mkTcEqPred xi2 xi1] xcomp xdecomp - - -- xcomp : [(xi2 ~ xi1)] -> (F tys ~ xi2) - xcomp [x] = EvCoercion (from_this_co `mkTcTransCo` mk_sym_co x) - xcomp _ = panic "No more goals!" - - -- xdecomp : (F tys ~ xi2) -> [(xi2 ~ xi1)] - xdecomp x = [EvCoercion (mk_sym_co x `mkTcTransCo` from_this_co)] - - mk_sym_co x = mkTcSymCo (evTermCoercion x) +reactFunEq from_this fsk1 (CtGiven { ctev_evtm = tm, ctev_loc = loc }) fsk2 + = do { let fsk_eq_co = mkTcSymCo (evTermCoercion tm) + `mkTcTransCo` ctEvCoercion from_this + -- :: fsk2 ~ fsk1 + fsk_eq_pred = mkTcEqPred (mkTyVarTy fsk2) (mkTyVarTy fsk1) + ; new_ev <- newGivenEvVar loc (fsk_eq_pred, EvCoercion fsk_eq_co) + ; emitWorkNC [new_ev] } + +reactFunEq from_this fuv1 (CtWanted { ctev_evar = evar }) fuv2 + = dischargeFmv evar fuv2 (ctEvCoercion from_this) (mkTyVarTy fuv1) + +reactFunEq _ _ solve_this@(CtDerived {}) _ + = pprPanic "reactFunEq" (ppr solve_this) \end{code} Note [Cache-caused loops] @@ -677,8 +675,8 @@ test when solving pairwise CFunEqCan. ********************************************************************************* \begin{code} -interactTyVarEq :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag) --- CTyEqCans are always consumed, returning Stop +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 }) | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i } <- findTyEqs (inert_eqs inerts) tv @@ -686,9 +684,9 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs , cc_ev , rhs_i `tcEqType` rhs ] = -- Inert: a ~ b -- Work item: a ~ b - do { when (isWanted ev) (setEvBind (ctev_evar ev) (ctEvTerm ev_i)) - ; traceFireTcS workItem (ptext (sLit "Solved from inert")) - ; return (Nothing, True) } + do { when (isWanted ev) $ + setEvBind (ctev_evar ev) (ctEvTerm ev_i) + ; stopWith ev "Solved from inert" } | Just tv_rhs <- getTyVar_maybe rhs , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i } @@ -697,41 +695,97 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs , cc_ev , rhs_i `tcEqType` mkTyVarTy tv ] = -- Inert: a ~ b -- Work item: b ~ a - do { when (isWanted ev) (setEvBind (ctev_evar ev) - (EvCoercion (mkTcSymCo (evTermCoercion (ctEvTerm ev_i))))) - ; traceFireTcS workItem (ptext (sLit "Solved from inert (r)")) - ; return (Nothing, True) } + do { when (isWanted ev) $ + setEvBind (ctev_evar ev) + (EvCoercion (mkTcSymCo (ctEvCoercion ev_i))) + ; stopWith ev "Solved from inert (r)" } | otherwise - = do { mb_solved <- trySpontaneousSolve ev tv rhs - ; case mb_solved of - SPCantSolve -- Includes givens - -> do { untch <- getUntouchables - ; traceTcS "Can't solve tyvar equality" - (vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv) - , ppWhen (isMetaTyVar tv) $ - nest 4 (text "Untouchable level of" <+> ppr tv - <+> text "is" <+> ppr (metaTyVarUntouchables tv)) - , text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs) - , text "Untouchables =" <+> ppr untch ]) - ; (n_kicked, inerts') <- kickOutRewritable ev tv inerts - ; traceFireTcS workItem $ - ptext (sLit "Kept as inert") <+> ppr_kicked n_kicked - ; return (Just (addInertCan inerts' workItem), True) } - - - SPSolved new_tv - -- Post: tv ~ xi is now in TyBinds, no need to put in inerts as well - -- see Note [Spontaneously solved in TyBinds] - -> do { (n_kicked, inerts') <- kickOutRewritable givenFlavour new_tv inerts - ; traceFireTcS workItem $ - ptext (sLit "Spontaneously solved") <+> ppr_kicked n_kicked - ; return (Just inerts', True) } } + = do { untch <- getUntouchables + ; if canSolveByUnification untch ev tv rhs + then do { solveByUnification ev tv rhs + ; n_kicked <- kickOutRewritable givenFlavour tv + -- givenFlavour because the tv := xi is given + ; return (Stop ev (ptext (sLit "Spontaneously solved") <+> ppr_kicked n_kicked)) } + + else do { traceTcS "Can't solve tyvar equality" + (vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv) + , ppWhen (isMetaTyVar tv) $ + nest 4 (text "Untouchable level of" <+> ppr tv + <+> text "is" <+> ppr (metaTyVarUntouchables tv)) + , text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs) + , text "Untouchables =" <+> ppr untch ]) + ; n_kicked <- kickOutRewritable ev tv + ; updInertCans (\ ics -> addInertCan ics workItem) + ; return (Stop ev (ptext (sLit "Kept as inert") <+> ppr_kicked n_kicked)) } } interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi) +-- @trySpontaneousSolve wi@ solves equalities where one side is a +-- touchable unification variable. +-- Returns True <=> spontaneous solve happened +canSolveByUnification :: Untouchables -> CtEvidence -> TcTyVar -> Xi -> Bool +canSolveByUnification untch gw tv xi + | isGiven gw -- See Note [Touchables and givens] + = False + + | isTouchableMetaTyVar untch tv + = case metaTyVarInfo tv of + SigTv -> is_tyvar xi + _ -> True + + | otherwise -- Untouchable + = False + where + is_tyvar xi + = case tcGetTyVar_maybe xi of + Nothing -> False + Just tv -> case tcTyVarDetails tv of + MetaTv { mtv_info = info } + -> case info of + SigTv -> True + _ -> False + SkolemTv {} -> True + FlatSkol {} -> False + RuntimeUnk -> True + +solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () +-- Solve with the identity coercion +-- Precondition: kind(xi) is a sub-kind of kind(tv) +-- Precondition: CtEvidence is Wanted or Derived +-- See [New Wanted Superclass Work] to see why solveByUnification +-- must work for Derived as well as Wanted +-- Returns: workItem where +-- workItem = the new Given constraint +-- +-- NB: No need for an occurs check here, because solveByUnification always +-- arises from a CTyEqCan, a *canonical* constraint. Its invariants +-- say that in (a ~ xi), the type variable a does not appear in xi. +-- See TcRnTypes.Ct invariants. +-- +-- Post: tv ~ xi is now in TyBinds, no need to put in inerts as well +-- see Note [Spontaneously solved in TyBinds] +solveByUnification wd tv xi + = do { let tv_ty = mkTyVarTy tv + ; traceTcS "Sneaky unification:" $ + vcat [text "Unifies:" <+> ppr tv <+> ptext (sLit ":=") <+> ppr xi, + text "Coercion:" <+> pprEq tv_ty xi, + text "Left Kind is:" <+> ppr (typeKind tv_ty), + text "Right Kind is:" <+> ppr (typeKind xi) ] + + ; let xi' = defaultKind xi + -- We only instantiate kind unification variables + -- with simple kinds like *, not OpenKind or ArgKind + -- cf TcUnify.uUnboundKVar + + ; setWantedTyBind tv xi' + ; when (isWanted wd) $ + setEvBind (ctEvId wd) (EvCoercion (mkTcNomReflCo xi')) } + + givenFlavour :: CtEvidence -- Used just to pass to kickOutRewritable +-- and to guide 'flatten' for givens givenFlavour = CtGiven { ctev_pred = panic "givenFlavour:ev" , ctev_evtm = panic "givenFlavour:tm" , ctev_loc = panic "givenFlavour:loc" } @@ -760,24 +814,32 @@ these binds /and/ the inerts for potentially unsolved or other given equalities. kickOutRewritable :: CtEvidence -- Flavour of the equality that is -- being added to the inert set -> TcTyVar -- The new equality is tv ~ ty - -> InertCans - -> TcS (Int, InertCans) + -> TcS Int kickOutRewritable new_ev new_tv - inert_cans@(IC { inert_eqs = tv_eqs - , inert_dicts = dictmap - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_insols = insols - , inert_no_eqs = no_eqs }) - | new_tv `elemVarEnv` tv_eqs -- Fast path: there is at least one equality for tv - -- so kick-out will do nothing - = return (0, inert_cans) + | not (new_ev `eqCanRewrite` new_ev) + = return 0 -- If new_ev can't rewrite itself, it can't rewrite + -- anything else, so no need to kick out anything + -- This is a common case: wanteds can't rewrite wanteds + | otherwise - = do { traceTcS "kickOutRewritable" $ - vcat [ text "tv = " <+> ppr new_tv - , ptext (sLit "Kicked out =") <+> ppr kicked_out] + = do { ics <- getInertCans + ; let (kicked_out, ics') = kick_out new_ev new_tv ics + ; setInertCans ics' ; updWorkListTcS (appendWorkList kicked_out) - ; return (workListSize kicked_out, inert_cans_in) } + + ; unless (isEmptyWorkList kicked_out) $ + csTraceTcS $ + hang (ptext (sLit "Kick out, tv =") <+> ppr new_tv) + 2 (ppr kicked_out) + ; return (workListSize kicked_out) } + +kick_out :: CtEvidence -> TcTyVar -> InertCans -> (WorkList, InertCans) +kick_out new_ev new_tv (IC { inert_eqs = tv_eqs + , inert_dicts = dictmap + , inert_funeqs = funeqmap + , inert_irreds = irreds + , inert_insols = insols }) + = (kicked_out, inert_cans_in) where -- NB: Notice that don't rewrite -- inert_solved_dicts, and inert_solved_funeqs @@ -787,52 +849,39 @@ kickOutRewritable new_ev new_tv , inert_dicts = dicts_in , inert_funeqs = feqs_in , inert_irreds = irs_in - , inert_insols = insols_in - , inert_no_eqs = no_eqs } + , inert_insols = insols_in } - kicked_out = WorkList { wl_eqs = tv_eqs_out - , wl_funeqs = foldrBag insertDeque emptyDeque feqs_out - , wl_rest = bagToList (dicts_out `andCts` irs_out - `andCts` insols_out) } + kicked_out = WL { wl_eqs = tv_eqs_out + , wl_funeqs = foldrBag insertDeque emptyDeque feqs_out + , wl_rest = bagToList (dicts_out `andCts` irs_out + `andCts` insols_out) + , wl_implics = emptyBag } (tv_eqs_out, tv_eqs_in) = foldVarEnv kick_out_eqs ([], emptyVarEnv) tv_eqs - (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap - (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap + (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap + (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap (irs_out, irs_in) = partitionBag kick_out_irred irreds (insols_out, insols_in) = partitionBag kick_out_ct insols -- Kick out even insolubles; see Note [Kick out insolubles] kick_out_ct :: Ct -> Bool - kick_out_ct ct = new_ev `canRewrite` ctEvidence ct + kick_out_ct ct = eqCanRewrite new_ev (ctEvidence ct) && new_tv `elemVarSet` tyVarsOfCt ct -- See Note [Kicking out inert constraints] kick_out_irred :: Ct -> Bool - kick_out_irred ct = new_ev `canRewrite` ctEvidence ct + kick_out_irred ct = eqCanRewrite new_ev (ctEvidence ct) && new_tv `elemVarSet` closeOverKinds (tyVarsOfCt ct) -- See Note [Kicking out Irreds] - kick_out_eqs :: EqualCtList -> ([Ct], TyVarEnv EqualCtList) + kick_out_eqs :: EqualCtList -> ([Ct], TyVarEnv EqualCtList) -> ([Ct], TyVarEnv EqualCtList) kick_out_eqs eqs (acc_out, acc_in) = (eqs_out ++ acc_out, case eqs_in of [] -> acc_in (eq1:_) -> extendVarEnv acc_in (cc_tyvar eq1) eqs_in) where - (eqs_out, eqs_in) = partition kick_out_eq eqs - - - kick_out_eq :: Ct -> Bool - kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs, cc_ev = ev }) - = (new_ev `canRewrite` ev) -- See Note [Delicate equality kick-out] - && (new_tv `elemVarSet` kind_vars || -- (1) - (not (ev `canRewrite` new_ev) && -- (2) - new_tv `elemVarSet` (extendVarSet (tyVarsOfType rhs) tv))) - where - kind_vars = tyVarsOfType (tyVarKind tv) `unionVarSet` - tyVarsOfType (typeKind rhs) - - kick_out_eq other_ct = pprPanic "kick_out_eq" (ppr other_ct) + (eqs_out, eqs_in) = partition kick_out_ct eqs \end{code} Note [Kicking out inert constraints] @@ -865,7 +914,6 @@ closeOverKinds to make sure we see k2. This is not pretty. Maybe (~) should have kind (~) :: forall k1 k1. k1 -> k2 -> Constraint - Note [Kick out insolubles] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have an insoluble alpha ~ [alpha], which is insoluble @@ -877,8 +925,17 @@ outer type constructors match. Note [Delicate equality kick-out] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When adding an equality (a ~ xi), we kick out an inert type-variable -equality (b ~ phi) in two cases +When adding an work-item CTyEqCan (a ~ xi), we kick out an inert +CTyEqCan (b ~ phi) when + + a) the work item can rewrite the inert item + +AND one of the following hold + +(0) If the new tyvar is the same as the old one + Work item: [G] a ~ blah + Inert: [W] a ~ foo + A particular case is when flatten-skolems get their value we must propagate (1) If the new tyvar appears in the kind vars of the LHS or RHS of the inert. Example: @@ -889,7 +946,8 @@ equality (b ~ phi) in two cases and can subsequently unify. (2) If the new tyvar appears in the RHS of the inert - AND the inert cannot rewrite the work item + AND not (the inert can rewrite the work item) <--------------------------------- + Work item: [G] a ~ b Inert: [W] b ~ [a] Now at this point the work item cannot be further rewritten by the @@ -903,65 +961,13 @@ equality (b ~ phi) in two cases Work item: [W] a ~ Int Inert: [W] b ~ [a] No need to kick out the inert, beause the inert substitution is not - necessarily idemopotent. See Note [Non-idempotent inert substitution]. + necessarily idemopotent. See Note [Non-idempotent inert substitution] + in TcFlatten. + Work item: [G] a ~ Int + Inert: [G] b ~ [a] See also Note [Detailed InertCans Invariants] -\begin{code} -data SPSolveResult = SPCantSolve - | SPSolved TcTyVar - -- We solved this /unification/ variable to some type using reflexivity - --- SPCantSolve means that we can't do the unification because e.g. the variable is untouchable --- SPSolved workItem' gives us a new *given* to go on - --- @trySpontaneousSolve wi@ solves equalities where one side is a --- touchable unification variable. -trySpontaneousSolve :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult -trySpontaneousSolve gw tv1 xi - | isGiven gw -- See Note [Touchables and givens] - = return SPCantSolve - - | Just tv2 <- tcGetTyVar_maybe xi - = do { tch1 <- isTouchableMetaTyVarTcS tv1 - ; tch2 <- isTouchableMetaTyVarTcS tv2 - ; case (tch1, tch2) of - (True, True) -> trySpontaneousEqTwoWay gw tv1 tv2 - (True, False) -> trySpontaneousEqOneWay gw tv1 xi - (False, True) -> trySpontaneousEqOneWay gw tv2 (mkTyVarTy tv1) - _ -> return SPCantSolve } - | otherwise - = do { tch1 <- isTouchableMetaTyVarTcS tv1 - ; if tch1 then trySpontaneousEqOneWay gw tv1 xi - else return SPCantSolve } - ----------------- -trySpontaneousEqOneWay :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult --- tv is a MetaTyVar, not untouchable -trySpontaneousEqOneWay gw tv xi - | not (isSigTyVar tv) || isTyVarTy xi - , typeKind xi `tcIsSubKind` tyVarKind tv - = solveWithIdentity gw tv xi - | otherwise -- Still can't solve, sig tyvar and non-variable rhs - = return SPCantSolve - ----------------- -trySpontaneousEqTwoWay :: CtEvidence -> TcTyVar -> TcTyVar -> TcS SPSolveResult --- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here - -trySpontaneousEqTwoWay gw tv1 tv2 - | k1 `tcIsSubKind` k2 && nicer_to_update_tv2 - = solveWithIdentity gw tv2 (mkTyVarTy tv1) - | k2 `tcIsSubKind` k1 - = solveWithIdentity gw tv1 (mkTyVarTy tv2) - | otherwise - = return SPCantSolve - where - k1 = tyVarKind tv1 - k2 = tyVarKind tv2 - nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2) -\end{code} - Note [Avoid double unifications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The spontaneous solver has to return a given which mentions the unified unification @@ -980,42 +986,6 @@ See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding double unifications is the main reason we disallow touchable unification variables as RHS of type family equations: F xis ~ alpha. -\begin{code} -solveWithIdentity :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult --- Solve with the identity coercion --- Precondition: kind(xi) is a sub-kind of kind(tv) --- Precondition: CtEvidence is Wanted or Derived --- See [New Wanted Superclass Work] to see why solveWithIdentity --- must work for Derived as well as Wanted --- Returns: workItem where --- workItem = the new Given constraint --- --- NB: No need for an occurs check here, because solveWithIdentity always --- arises from a CTyEqCan, a *canonical* constraint. Its invariants --- say that in (a ~ xi), the type variable a does not appear in xi. --- See TcRnTypes.Ct invariants. -solveWithIdentity wd tv xi - = do { let tv_ty = mkTyVarTy tv - ; traceTcS "Sneaky unification:" $ - vcat [text "Unifies:" <+> ppr tv <+> ptext (sLit ":=") <+> ppr xi, - text "Coercion:" <+> pprEq tv_ty xi, - text "Left Kind is:" <+> ppr (typeKind tv_ty), - text "Right Kind is:" <+> ppr (typeKind xi) ] - - ; let xi' = defaultKind xi - -- We only instantiate kind unification variables - -- with simple kinds like *, not OpenKind or ArgKind - -- cf TcUnify.uUnboundKVar - - ; setWantedTyBind tv xi' - ; let refl_evtm = EvCoercion (mkTcNomReflCo xi') - - ; when (isWanted wd) $ - setEvBind (ctev_evar wd) refl_evtm - - ; return (SPSolved tv) } -\end{code} - Note [Superclasses and recursive dictionaries] @@ -1363,38 +1333,23 @@ To achieve this required some refactoring of FunDeps.lhs (nicer now!). \begin{code} -rewriteWithFunDeps :: [Equation CtLoc] -> TcS [Ct] +rewriteWithFunDeps :: [Equation CtLoc] -> TcS () -- NB: The returned constraints are all Derived -- Post: returns no trivial equalities (identities) and all EvVars returned are fresh rewriteWithFunDeps eqn_pred_locs - = do { fd_cts <- mapM instFunDepEqn eqn_pred_locs - ; return (concat fd_cts) } + = mapM_ instFunDepEqn eqn_pred_locs -instFunDepEqn :: Equation CtLoc -> TcS [Ct] +instFunDepEqn :: Equation CtLoc -> TcS () -- Post: Returns the position index as well as the corresponding FunDep equality instFunDepEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc }) = do { (subst, _) <- instFlexiTcS tvs -- Takes account of kind substitution - ; foldM (do_one subst) [] eqs } + ; mapM_ (do_one subst) eqs } where - do_one subst ievs (FDEq { fd_ty_left = ty1, fd_ty_right = ty2 }) - | tcEqType sty1 sty2 - = return ievs -- Return no trivial equalities - | otherwise - = do { mb_eqv <- newDerived loc (mkTcEqPred sty1 sty2) - ; case mb_eqv of - Just ev -> return (mkNonCanonical (ev {ctev_loc = loc}) : ievs) - Nothing -> return ievs } - -- We are eventually going to emit FD work back in the work list so - -- it is important that we only return the /freshly created/ and not - -- some existing equality! - where - sty1 = Type.substTy subst ty1 - sty2 = Type.substTy subst ty2 + 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 @@ -1402,23 +1357,15 @@ instFunDepEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc }) ********************************************************************************* \begin{code} -topReactionsStage :: WorkItem -> TcS StopOrContinue +topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) topReactionsStage wi = do { inerts <- getTcSInerts ; tir <- doTopReact inerts wi ; case tir of - NoTopInt -> return (ContinueWith wi) - SomeTopInt rule what_next - -> do { traceFireTcS wi $ - ptext (sLit "Top react:") <+> text rule - ; return what_next } } + ContinueWith wi -> return (ContinueWith wi) + Stop ev s -> return (Stop ev (ptext (sLit "Top react:") <+> s)) } -data TopInteractResult - = NoTopInt - | SomeTopInt { tir_rule :: String, tir_new_item :: StopOrContinue } - - -doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult +doTopReact :: InertSet -> WorkItem -> TcS (StopOrContinue Ct) -- The work item does not react with the inert set, so try interaction with top-level -- instances. Note: -- @@ -1429,30 +1376,26 @@ doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult -- (b) See Note [Given constraint that matches an instance declaration] -- for some design decisions for given dictionaries. -doTopReact inerts workItem - = do { traceTcS "doTopReact" (ppr workItem) - ; case workItem of - CDictCan { cc_ev = fl, cc_class = cls, cc_tyargs = xis } - -> doTopReactDict inerts fl cls xis - - CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = args , cc_rhs = xi } - -> doTopReactFunEq workItem fl tc args xi - +doTopReact inerts work_item + = do { traceTcS "doTopReact" (ppr work_item) + ; case work_item of + CDictCan {} -> doTopReactDict inerts work_item + CFunEqCan {} -> doTopReactFunEq work_item _ -> -- Any other work item does not react with any top-level equations - return NoTopInt } + return (ContinueWith work_item) } -------------------- -doTopReactDict :: InertSet -> CtEvidence -> Class -> [Xi] -> TcS TopInteractResult +doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct) -- Try to use type-class instance declarations to simplify the constraint -doTopReactDict inerts fl cls xis +doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls + , cc_tyargs = xis }) | not (isWanted fl) -- Never use instances for Given or Derived constraints = try_fundeps_and_return | Just ev <- lookupSolvedDict inerts cls xis -- Cached - , ctEvCheckDepth (ctLocDepth (ctev_loc fl)) ev + , ctEvCheckDepth (ctLocDepth loc) ev = do { setEvBind dict_id (ctEvTerm ev); - ; return $ SomeTopInt { tir_rule = "Dict/Top (cached)" - , tir_new_item = Stop } } + ; stopWith fl "Dict/Top (cached)" } | otherwise -- Not cached = do { lkup_inst_res <- matchClassInst inerts cls xis loc @@ -1461,20 +1404,18 @@ doTopReactDict inerts fl cls xis ; solve_from_instance wtvs ev_term } NoInstance -> try_fundeps_and_return } where - dict_id = ctEvId fl + dict_id = ASSERT( isWanted fl ) ctEvId fl pred = mkClassPred cls xis - loc = ctev_loc fl + loc = ctEvLoc fl - solve_from_instance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult + solve_from_instance :: [CtEvidence] -> EvTerm -> TcS (StopOrContinue Ct) -- Precondition: evidence term matches the predicate workItem solve_from_instance evs ev_term | null evs = do { traceTcS "doTopReact/found nullary instance for" $ ppr dict_id ; setEvBind dict_id ev_term - ; return $ - SomeTopInt { tir_rule = "Dict/Top (solved, no new work)" - , tir_new_item = Stop } } + ; stopWith fl "Dict/Top (solved, no new work)" } | otherwise = do { traceTcS "doTopReact/found non-nullary instance for" $ ppr dict_id @@ -1482,9 +1423,7 @@ doTopReactDict inerts fl cls xis ; let mk_new_wanted ev = mkNonCanonical (ev {ctev_loc = bumpCtLocDepth CountConstraints loc }) ; updWorkListTcS (extendWorkListCts (map mk_new_wanted evs)) - ; return $ - SomeTopInt { tir_rule = "Dict/Top (solved, more work)" - , tir_new_item = Stop } } + ; stopWith fl "Dict/Top (solved, more work)" } -- We didn't solve it; so try functional dependencies with -- the instance environment, and return @@ -1497,66 +1436,135 @@ doTopReactDict inerts fl cls xis fd_eqns = [ fd { fd_loc = loc { ctl_origin = FunDepOrigin2 pred (ctl_origin loc) inst_pred inst_loc } } | fd@(FDEqn { fd_loc = inst_loc, fd_pred1 = inst_pred }) - <- improveFromInstEnv instEnvs pred ] - ; fd_work <- rewriteWithFunDeps fd_eqns - ; unless (null fd_work) $ - do { traceTcS "Addig FD work" (ppr pred $$ vcat (map pprEquation fd_eqns) $$ ppr fd_work) - ; updWorkListTcS (extendWorkListEqs fd_work) } - ; return NoTopInt } + <- improveFromInstEnv instEnvs pred ] + ; rewriteWithFunDeps fd_eqns + ; continueWith work_item } --------------------- -doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi -> TcS TopInteractResult -doTopReactFunEq _ct fl fun_tc args xi - = ASSERT(isSynFamilyTyCon fun_tc) -- No associated data families have - -- reached this far - -- Look in the cache of solved funeqs - do { fun_eq_cache <- getTcSInerts >>= (return . inert_solved_funeqs) - ; case findFunEq fun_eq_cache fun_tc args of { - Just (ctev, rhs_ty) - | ctev `canRewriteOrSame` fl -- See Note [Cached solved FunEqs] - -> ASSERT( not (isDerived ctev) ) - succeed_with "Fun/Cache" (evTermCoercion (ctEvTerm ctev)) rhs_ty ; - _other -> +doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) +-------------------- +doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct) +doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc + , cc_tyargs = args , cc_fsk = fsk }) + = ASSERT(isSynFamilyTyCon fam_tc) -- No associated data families + -- have reached this far + ASSERT( not (isDerived old_ev) ) -- CFunEqCan is never Derived -- Look up in top-level instances, or built-in axiom - do { match_res <- matchFam fun_tc args -- See Note [MATCHING-SYNONYMS] + do { match_res <- matchFam fam_tc args -- See Note [MATCHING-SYNONYMS] ; case match_res of { - Nothing -> do { try_improvement; return NoTopInt } ; - Just (co, ty) -> + Nothing -> do { try_improvement; continueWith work_item } ; + Just (ax_co, rhs_ty) -- Found a top-level instance - do { -- Add it to the solved goals - unless (isDerived fl) (addSolvedFunEq fun_tc args fl xi) - ; succeed_with "Fun/Top" co ty } } } } } + | Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty + , isSynFamilyTyCon tc + , tc_args `lengthIs` tyConArity tc -- Short-cut + -> shortCutReduction old_ev fsk ax_co tc tc_args + -- Try shortcut; see Note [Short cut for top-level reaction] + + | isGiven old_ev -- Not shortcut + -> do { let final_co = mkTcSymCo (ctEvCoercion old_ev) `mkTcTransCo` ax_co + -- final_co :: fsk ~ rhs_ty + ; new_ev <- newGivenEvVar deeper_loc (mkTcEqPred (mkTyVarTy fsk) rhs_ty, + EvCoercion final_co) + ; emitWorkNC [new_ev] -- Non-cannonical; that will mean we flatten rhs_ty + ; stopWith old_ev "Fun/Top (given)" } + + | not (fsk `elemVarSet` tyVarsOfType rhs_ty) + -> do { dischargeFmv (ctEvId old_ev) fsk ax_co rhs_ty + ; traceTcS "doTopReactFunEq" $ + vcat [ text "old_ev:" <+> ppr old_ev + , nest 2 (text ":=") <+> ppr ax_co ] + ; stopWith old_ev "Fun/Top (wanted)" } + + | otherwise -- We must not assign ufsk := ...ufsk...! + -> do { alpha_ty <- newFlexiTcSTy (tyVarKind fsk) + ; new_ev <- newWantedEvVarNC loc (mkTcEqPred alpha_ty rhs_ty) + ; let final_co = ax_co `mkTcTransCo` mkTcSymCo (ctEvCoercion new_ev) + -- ax_co :: fam_tc args ~ rhs_ty + -- ev :: alpha ~ rhs_ty + -- ufsk := alpha + -- final_co :: fam_tc args ~ alpha + ; dischargeFmv (ctEvId old_ev) fsk final_co alpha_ty + ; traceTcS "doTopReactFunEq (occurs)" $ + vcat [ text "old_ev:" <+> ppr old_ev + , nest 2 (text ":=") <+> ppr final_co + , text "new_ev:" <+> ppr new_ev ] + ; emitWorkNC [new_ev] + -- By emitting this as non-canonical, we deal with all + -- flattening, occurs-check, and ufsk := ufsk issues + ; stopWith old_ev "Fun/Top (wanted)" } } } where - loc = ctev_loc fl + loc = ctEvLoc old_ev + deeper_loc = bumpCtLocDepth CountTyFunApps loc try_improvement - | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc - = do { let eqns = sfInteractTop ops args xi - ; impsMb <- mapM (\(Pair x y) -> newDerived loc (mkTcEqPred x y)) eqns - ; let work = map mkNonCanonical (catMaybes impsMb) - ; unless (null work) (updWorkListTcS (extendWorkListEqs work)) } + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = do { inert_eqs <- getInertEqs + ; let eqns = sfInteractTop ops args (lookupFlattenTyVar inert_eqs fsk) + ; mapM_ (emitNewDerivedEq loc) eqns } | otherwise = return () - succeed_with :: String -> TcCoercion -> TcType -> TcS TopInteractResult - succeed_with str co rhs_ty -- co :: fun_tc args ~ rhs_ty - = do { ctevs <- xCtEvidence fl xev - ; traceTcS ("doTopReactFunEq " ++ str) (ppr ctevs) - ; case ctevs of - [ctev] -> updWorkListTcS $ extendWorkListEq $ - mkNonCanonical (ctev { ctev_loc = bumpCtLocDepth CountTyFunApps loc }) - ctevs -> -- No subgoal (because it's cached) - ASSERT( null ctevs) return () - ; return $ SomeTopInt { tir_rule = str - , tir_new_item = Stop } } - where - xdecomp x = [EvCoercion (mkTcSymCo co `mkTcTransCo` evTermCoercion x)] - xcomp [x] = EvCoercion (co `mkTcTransCo` evTermCoercion x) - xcomp _ = panic "No more goals!" - xev = XEvTerm [mkTcEqPred rhs_ty xi] xcomp xdecomp +doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w) + +shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion + -> TyCon -> [TcType] -> TcS (StopOrContinue Ct) +shortCutReduction old_ev fsk ax_co fam_tc tc_args + | isGiven old_ev + = do { (xis, cos) <- flattenMany (FE { fe_ev = old_ev, fe_mode = FM_FlattenAll }) tc_args + -- ax_co :: F args ~ G tc_args + -- cos :: xis ~ tc_args + -- old_ev :: F args ~ fsk + -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk + + ; new_ev <- newGivenEvVar deeper_loc + ( mkTcEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk) + , EvCoercion (mkTcTyConAppCo Nominal fam_tc cos + `mkTcTransCo` mkTcSymCo ax_co + `mkTcTransCo` ctEvCoercion old_ev) ) + + ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc, cc_tyargs = xis, cc_fsk = fsk } + ; updWorkListTcS (extendWorkListFunEq new_ct) + ; stopWith old_ev "Fun/Top (given, shortcut)" } + + | otherwise + = ASSERT( not (isDerived old_ev) ) -- Caller ensures this + do { (xis, cos) <- flattenMany (FE { fe_ev = old_ev, fe_mode = FM_FlattenAll }) tc_args + -- ax_co :: F args ~ G tc_args + -- cos :: xis ~ tc_args + -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk + -- new_ev :: G xis ~ fsk + -- old_ev :: F args ~ fsk := ax_co ; sym (G cos) ; new_ev + + ; new_ev <- newWantedEvVarNC loc (mkTcEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk)) + ; setEvBind (ctEvId old_ev) + (EvCoercion (ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal fam_tc cos) + `mkTcTransCo` ctEvCoercion new_ev)) + + ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc, cc_tyargs = xis, cc_fsk = fsk } + ; updWorkListTcS (extendWorkListFunEq new_ct) + ; stopWith old_ev "Fun/Top (wanted, shortcut)" } + where + loc = ctEvLoc old_ev + deeper_loc = bumpCtLocDepth CountTyFunApps loc + +dischargeFmv :: EvVar -> TcTyVar -> TcCoercion -> TcType -> TcS () +-- (dischargeFmv x fmv co ty) +-- [W] x :: F tys ~ fuv +-- co :: F tys ~ ty +-- Precondition: fuv is not filled, and fuv `notElem` ty +-- +-- Then set fuv := ty, +-- set x := co +-- kick out any inert things that are now rewritable +dischargeFmv evar fmv co xi + = ASSERT2( not (fmv `elemVarSet` tyVarsOfType xi), ppr evar $$ ppr fmv $$ ppr xi ) + do { setWantedTyBind fmv 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] @@ -1836,13 +1844,15 @@ matchClassInst _ clas [ ty ] _ -} makeDict evLit | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] + -- co_dict :: KnownNat n ~ SNat n , [ meth ] <- classMethods clas , Just tcRep <- tyConAppTyCon_maybe -- SNat $ funResultTy -- SNat n $ dropForAlls -- KnownNat n => SNat n $ idType meth -- forall n. KnownNat n => SNat n , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] - = return (GenInst [] $ mkEvCast (EvLit evLit) (mkTcTransCo co_dict co_rep)) + -- SNat n ~ Integer + = return (GenInst [] $ mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep))) | otherwise = panicTcS (text "Unexpected evidence for" <+> ppr (className clas) @@ -1909,7 +1919,7 @@ matchClassInst inerts clas tys loc { evc_vars <- instDFunConstraints loc theta ; let new_ev_vars = freshGoals evc_vars -- new_ev_vars are only the real new variables that can be emitted - dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars) + dfun_app = EvDFunApp dfun_id tys (map (ctEvTerm . fst) evc_vars) ; return $ GenInst new_ev_vars dfun_app } } givens_for_this_clas :: Cts @@ -2028,10 +2038,9 @@ requestCoercible :: CtLoc -> TcType -> TcType , TcCoercion ) -- Coercion witnessing (Coercible t1 t2) requestCoercible loc ty1 ty2 = ASSERT2( typeKind ty1 `tcEqKind` typeKind ty2, ppr ty1 <+> ppr ty2) - do { mb_ev <- newWantedEvVarNonrec loc' (mkCoerciblePred ty1 ty2) - ; case mb_ev of - Fresh ev -> return ( [ev], evTermCoercion (ctEvTerm ev) ) - Cached ev_tm -> return ( [], evTermCoercion ev_tm ) } + do { (new_ev, freshness) <- newWantedEvVarNonrec loc' (mkCoerciblePred ty1 ty2) + ; return ( case freshness of { Fresh -> [new_ev]; Cached -> [] } + , ctEvCoercion new_ev) } -- Evidence for a Coercible constraint is always a coercion t1 ~R t2 where loc' = bumpCtLocDepth CountConstraints loc diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 301801ab91..d6f37c8f96 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -1,4 +1,4 @@ -o% +% % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % @@ -37,11 +37,13 @@ module TcMType ( -- Instantiation tcInstTyVars, newSigTyVar, tcInstType, - tcInstSkolTyVars, tcInstSuperSkolTyVars,tcInstSuperSkolTyVarsX, + tcInstSkolTyVars, tcInstSuperSkolTyVarsX, tcInstSigTyVarsLoc, tcInstSigTyVars, - tcInstSkolTyVar, tcInstSkolType, + tcInstSkolType, tcSkolDFunType, tcSuperSkolTyVars, + instSkolTyVars, freshenTyVarBndrs, + -------------------------------- -- Zonking zonkTcPredType, @@ -51,7 +53,7 @@ module TcMType ( zonkTcTyVarBndr, zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcKind, defaultKindVarToStar, - zonkEvVar, zonkWC, zonkFlats, zonkId, zonkCt, zonkCts, zonkSkolemInfo, + zonkEvVar, zonkWC, zonkFlats, zonkId, zonkCt, zonkSkolemInfo, tcGetGlobalTyVars, ) where @@ -61,10 +63,8 @@ module TcMType ( -- friends: import TypeRep import TcType -import TcEvidence import Type import Class -import TyCon import Var -- others: @@ -195,10 +195,9 @@ tcInstType inst_tyvars ty ; return (tyvars', theta, tau) } tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType) --- Instantiate a type signature with skolem constants, but --- do *not* give them fresh names, because we want the name to --- be in the type environment: it is lexically scoped. -tcSkolDFunType ty = tcInstType (\tvs -> return (tcSuperSkolTyVars tvs)) ty +-- Instantiate a type signature with skolem constants. +-- We could give them fresh names, but no need to do so +tcSkolDFunType ty = tcInstType tcInstSuperSkolTyVars ty tcSuperSkolTyVars :: [TyVar] -> (TvSubst, [TcTyVar]) -- Make skolem constants, but do *not* give them new names, as above @@ -214,73 +213,73 @@ tcSuperSkolTyVar subst tv kind = substTy subst (tyVarKind tv) new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv -tcInstSkolTyVar :: SrcSpan -> Bool -> TvSubst -> TyVar - -> TcRnIf gbl lcl (TvSubst, TcTyVar) --- Instantiate the tyvar, using --- * the occ-name and kind of the supplied tyvar, --- * the unique from the monad, --- * the location either from the tyvar (skol_info = SigSkol) --- or from the monad (otherwise) -tcInstSkolTyVar loc overlappable subst tyvar - = do { uniq <- newUnique - ; let new_name = mkInternalName uniq occ loc - new_tv = mkTcTyVar new_name kind (SkolemTv overlappable) - ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } - where - old_name = tyVarName tyvar - occ = nameOccName old_name - kind = substTy subst (tyVarKind tyvar) - --- Wrappers --- we need to be able to do this from outside the TcM monad: tcInstSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) -tcInstSkolTyVars = tcInstSkolTyVarsX (mkTopTvSubst []) +tcInstSkolTyVars = tcInstSkolTyVars' False emptyTvSubst -tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar] -tcInstSuperSkolTyVars = fmap snd . tcInstSkolTyVars' True (mkTopTvSubst []) +tcInstSuperSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) +tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTvSubst -tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX - :: TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) -tcInstSkolTyVarsX subst = tcInstSkolTyVars' False subst -tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst +tcInstSuperSkolTyVarsX :: TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) +tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) -- Precondition: tyvars should be ordered (kind vars first) -- see Note [Kind substitution when instantiating] -- Get the location from the monad; this is a complete freshening operation -tcInstSkolTyVars' isSuperSkol subst tvs +tcInstSkolTyVars' overlappable subst tvs = do { loc <- getSrcSpanM - ; mapAccumLM (tcInstSkolTyVar loc isSuperSkol) subst tvs } + ; instSkolTyVarsX (mkTcSkolTyVar loc overlappable) subst tvs } + +mkTcSkolTyVar :: SrcSpan -> Bool -> Unique -> Name -> Kind -> TcTyVar +mkTcSkolTyVar loc overlappable uniq old_name kind + = mkTcTyVar (mkInternalName uniq (getOccName old_name) loc) + kind + (SkolemTv overlappable) tcInstSigTyVarsLoc :: SrcSpan -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar]) -- We specify the location -tcInstSigTyVarsLoc loc = mapAccumLM (tcInstSkolTyVar loc False) (mkTopTvSubst []) +tcInstSigTyVarsLoc loc = instSkolTyVars (mkTcSkolTyVar loc False) tcInstSigTyVars :: [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar]) -- Get the location from the TyVar itself, not the monad -tcInstSigTyVars = mapAccumLM inst_tv (mkTopTvSubst []) +tcInstSigTyVars + = instSkolTyVars mk_tv where - inst_tv subst tv = tcInstSkolTyVar (getSrcSpan tv) False subst tv + mk_tv uniq old_name kind + = mkTcTyVar (setNameUnique old_name uniq) kind (SkolemTv False) tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type with fresh skolem constants -- Binding location comes from the monad tcInstSkolType ty = tcInstType tcInstSkolTyVars ty -newSigTyVar :: Name -> Kind -> TcM TcTyVar -newSigTyVar name kind - = do { uniq <- newUnique - ; let name' = setNameUnique name uniq - -- Use the same OccName so that the tidy-er - -- doesn't gratuitously rename 'a' to 'a0' etc - ; details <- newMetaDetails SigTv - ; return (mkTcTyVar name' kind details) } +------------------ +freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar]) +-- ^ Give fresh uniques to a bunch of TyVars, but they stay +-- as TyVars, rather than becoming TcTyVars +-- Used in FamInst.newFamInst, and Inst.newClsInst +freshenTyVarBndrs = instSkolTyVars mk_tv + where + mk_tv uniq old_name kind = mkTyVar (setNameUnique old_name uniq) kind -newMetaDetails :: MetaInfo -> TcM TcTyVarDetails -newMetaDetails info - = do { ref <- newMutVar Flexi - ; untch <- getUntouchables - ; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_untch = untch }) } +------------------ +instSkolTyVars :: (Unique -> Name -> Kind -> TyVar) + -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar]) +instSkolTyVars mk_tv = instSkolTyVarsX mk_tv emptyTvSubst + +instSkolTyVarsX :: (Unique -> Name -> Kind -> TyVar) + -> TvSubst -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar]) +instSkolTyVarsX mk_tv = mapAccumLM (instSkolTyVarX mk_tv) + +instSkolTyVarX :: (Unique -> Name -> Kind -> TyVar) + -> TvSubst -> TyVar -> TcRnIf gbl lcl (TvSubst, TyVar) +instSkolTyVarX mk_tv subst tyvar + = do { uniq <- newUnique + ; let new_tv = mk_tv uniq old_name kind + ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } + where + old_name = tyVarName tyvar + kind = substTy subst (tyVarKind tyvar) \end{code} Note [Kind substitution when instantiating] @@ -312,12 +311,28 @@ newMetaTyVar meta_info kind = do { uniq <- newUnique ; let name = mkTcTyVarName uniq s s = case meta_info of - PolyTv -> fsLit "s" - TauTv -> fsLit "t" - SigTv -> fsLit "a" + PolyTv -> fsLit "s" + TauTv -> fsLit "t" + FlatMetaTv -> fsLit "fmv" + SigTv -> fsLit "a" ; details <- newMetaDetails meta_info ; return (mkTcTyVar name kind details) } +newSigTyVar :: Name -> Kind -> TcM TcTyVar +newSigTyVar name kind + = do { uniq <- newUnique + ; let name' = setNameUnique name uniq + -- Use the same OccName so that the tidy-er + -- doesn't gratuitously rename 'a' to 'a0' etc + ; details <- newMetaDetails SigTv + ; return (mkTcTyVar name' kind details) } + +newMetaDetails :: MetaInfo -> TcM TcTyVarDetails +newMetaDetails info + = do { ref <- newMutVar Flexi + ; untch <- getUntouchables + ; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_untch = untch }) } + cloneMetaTyVar :: TcTyVar -> TcM TcTyVar cloneMetaTyVar tv = ASSERT( isTcTyVar tv ) @@ -437,22 +452,16 @@ newPolyFlexiTyVarTy :: TcM TcType newPolyFlexiTyVarTy = do { tv <- newMetaTyVar PolyTv liftedTypeKind ; return (TyVarTy tv) } -tcInstTyVars :: [TKVar] -> TcM ([TcTyVar], [TcType], TvSubst) +tcInstTyVars :: [TKVar] -> TcM (TvSubst, [TcTyVar]) -- Instantiate with META type variables -- Note that this works for a sequence of kind and type -- variables. Eg [ (k:BOX), (a:k->k) ] -- Gives [ (k7:BOX), (a8:k7->k7) ] -tcInstTyVars tyvars = tcInstTyVarsX emptyTvSubst tyvars +tcInstTyVars tyvars = mapAccumLM tcInstTyVarX emptyTvSubst tyvars -- emptyTvSubst has an empty in-scope set, but that's fine here -- Since the tyvars are freshly made, they cannot possibly be -- captured by any existing for-alls. -tcInstTyVarsX :: TvSubst -> [TKVar] -> TcM ([TcTyVar], [TcType], TvSubst) --- The "X" part is because of extending the substitution -tcInstTyVarsX subst tyvars = - do { (subst', tyvars') <- mapAccumLM tcInstTyVarX subst tyvars - ; return (tyvars', mkTyVarTys tyvars', subst') } - tcInstTyVarX :: TvSubst -> TKVar -> TcM (TvSubst, TcTyVar) -- Make a new unification variable tyvar whose Name and Kind come from -- an existing TyVar. We substitute kind variables in the kind. @@ -585,6 +594,7 @@ skolemiseUnboundMetaTyVar tv details final_name = mkInternalName uniq (getOccName tv) span final_tv = mkTcTyVar final_name final_kind details + ; traceTc "Skolemising" (ppr tv <+> ptext (sLit ":=") <+> ppr final_tv) ; writeMetaTyVar tv (mkTyVarTy final_tv) ; return final_tv } \end{code} @@ -657,7 +667,7 @@ a \/\a in the final result but all the occurrences of a will be zonked to () %************************************************************************ %* * - Zonking + Zonking types %* * %************************************************************************ @@ -676,8 +686,6 @@ tcGetGlobalTyVars where \end{code} ------------------ Type variables - \begin{code} zonkTcTypeAndFV :: TcType -> TcM TyVarSet -- Zonk a type and take its free variables @@ -718,13 +726,15 @@ zonkTcPredType :: TcPredType -> TcM TcPredType zonkTcPredType = zonkTcType \end{code} ---------------- Constraints +%************************************************************************ +%* * + Zonking constraints +%* * +%************************************************************************ \begin{code} zonkImplication :: Implication -> TcM (Bag Implication) -zonkImplication implic@(Implic { ic_untch = untch - , ic_binds = binds_var - , ic_skols = skols +zonkImplication implic@(Implic { ic_skols = skols , ic_given = given , ic_wanted = wanted , ic_info = info }) @@ -732,12 +742,11 @@ zonkImplication implic@(Implic { ic_untch = untch -- as Trac #7230 showed ; given' <- mapM zonkEvVar given ; info' <- zonkSkolemInfo info - ; wanted' <- zonkWCRec binds_var untch wanted + ; wanted' <- zonkWCRec wanted ; if isEmptyWC wanted' then return emptyBag else return $ unitBag $ - implic { ic_fsks = [] -- Zonking removes all FlatSkol tyvars - , ic_skols = skols' + implic { ic_skols = skols' , ic_given = given' , ic_wanted = wanted' , ic_info = info' } } @@ -747,105 +756,25 @@ zonkEvVar var = do { ty' <- zonkTcType (varType var) ; return (setVarType var ty') } -zonkWC :: EvBindsVar -- May add new bindings for wanted family equalities in here - -> WantedConstraints -> TcM WantedConstraints -zonkWC binds_var wc - = do { untch <- getUntouchables - ; zonkWCRec binds_var untch wc } +zonkWC :: WantedConstraints -> TcM WantedConstraints +zonkWC wc = zonkWCRec wc -zonkWCRec :: EvBindsVar - -> Untouchables - -> WantedConstraints -> TcM WantedConstraints -zonkWCRec binds_var untch (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) - = do { flat' <- zonkFlats binds_var untch flat +zonkWCRec :: WantedConstraints -> TcM WantedConstraints +zonkWCRec (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) + = do { flat' <- zonkFlats flat ; implic' <- flatMapBagM zonkImplication implic - ; insol' <- zonkCts insol -- No need to do the more elaborate zonkFlats thing + ; insol' <- zonkFlats insol ; return (WC { wc_flat = flat', wc_impl = implic', wc_insol = insol' }) } - -zonkFlats :: EvBindsVar -> Untouchables -> Cts -> TcM Cts --- This zonks and unflattens a bunch of flat constraints --- See Note [Unflattening while zonking] -zonkFlats binds_var untch cts - = do { -- See Note [How to unflatten] - cts <- foldrBagM unflatten_one emptyCts cts - ; zonkCts cts } - where - unflatten_one orig_ct cts - = do { zct <- zonkCt orig_ct -- First we need to fully zonk - ; mct <- try_zonk_fun_eq orig_ct zct -- Then try to solve if family equation - ; return $ maybe cts (`consBag` cts) mct } - - try_zonk_fun_eq orig_ct zct -- See Note [How to unflatten] - | EqPred ty_lhs ty_rhs <- classifyPredType (ctPred zct) - -- NB: zonking de-classifies the constraint, - -- so we can't look for CFunEqCan - , Just tv <- getTyVar_maybe ty_rhs - , ASSERT2( not (isFloatedTouchableMetaTyVar untch tv), ppr tv ) - isTouchableMetaTyVar untch tv - , not (isSigTyVar tv) || isTyVarTy ty_lhs -- Never unify a SigTyVar with a non-tyvar - , typeKind ty_lhs `tcIsSubKind` tyVarKind tv -- c.f. TcInteract.trySpontaneousEqOneWay - , not (tv `elemVarSet` tyVarsOfType ty_lhs) -- Do not construct an infinite type - = ASSERT2( case tcSplitTyConApp_maybe ty_lhs of { Just (tc,_) -> isSynFamilyTyCon tc; _ -> False }, ppr orig_ct ) - do { writeMetaTyVar tv ty_lhs - ; let evterm = EvCoercion (mkTcNomReflCo ty_lhs) - evvar = ctev_evar (cc_ev zct) - ; when (isWantedCt orig_ct) $ -- Can be derived (Trac #8129) - addTcEvBind binds_var evvar evterm - ; traceTc "zonkFlats/unflattening" $ - vcat [ text "zct = " <+> ppr zct, - text "binds_var = " <+> ppr binds_var ] - ; return Nothing } - | otherwise - = return (Just zct) \end{code} -Note [Unflattening while zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A bunch of wanted constraints could contain wanted equations of the form -(F taus ~ alpha) where alpha is either an ordinary unification variable, or -a flatten unification variable. - -These are ordinary wanted constraints and can/should be solved by -ordinary unification alpha := F taus. However the constraint solving -algorithm does not do that, as their 'inert' form is F taus ~ alpha. - -Hence, we need an extra step to 'unflatten' these equations by -performing unification. This unification, if it happens at the end of -constraint solving, cannot produce any more interactions in the -constraint solver so it is safe to do it as the very very last step. - -We choose therefore to do it during zonking, in the function -zonkFlats. This is in analogy to the zonking of given "flatten skolems" -which are eliminated in favor of the underlying type that they are -equal to. - -Note that, because we now have to affect *evidence* while zonking -(setting some evidence binds to identities), we have to pass to the -zonkWC function an evidence variable to collect all the extra -variables. - -Note [How to unflatten] -~~~~~~~~~~~~~~~~~~~~~~~ -How do we unflatten during zonking. Consider a bunch of flat constraints. -Consider them one by one. For each such constraint C - * Zonk C (to apply current substitution) - * If C is of form F tys ~ alpha, - where alpha is touchable - and alpha is not mentioned in tys - then unify alpha := F tys - and discard C - -After processing all the flat constraints, zonk them again to propagate -the inforamtion from later ones to earlier ones. Eg - Start: (F alpha ~ beta, G Int ~ alpha) - Then we get beta := F alpha - alpha := G Int - but we must apply the second unification to the first constraint. - - \begin{code} -zonkCts :: Cts -> TcM Cts -zonkCts = mapBagM zonkCt +zonkFlats :: Cts -> TcM Cts +zonkFlats cts = do { cts' <- mapBagM zonkCt' cts + ; traceTc "zonkFlats done:" (ppr cts') + ; return cts' } + +zonkCt' :: Ct -> TcM Ct +zonkCt' ct = zonkCt ct zonkCt :: Ct -> TcM Ct zonkCt ct@(CHoleCan { cc_ev = ev }) diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 2f86f376bd..6fdbc5214c 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -787,7 +787,7 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside = do { let (univ_tvs, ex_tvs, prov_theta, req_theta, arg_tys, ty) = patSynSig pat_syn - ; (univ_tvs', inst_tys, subst) <- tcInstTyVars univ_tvs + ; (subst, univ_tvs') <- tcInstTyVars univ_tvs ; checkExistentials ex_tvs penv ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs @@ -817,7 +817,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside LamPat mc -> PatSkol (PatSynCon pat_syn) mc LetPat {} -> UnkSkol -- Doesn't matter - ; req_wrap <- instCall PatOrigin inst_tys req_theta' + ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta' ; traceTc "instCall" (ppr req_wrap) ; traceTc "checkConstraints {" Outputable.empty @@ -848,10 +848,10 @@ matchExpectedPatTy inner_match pat_ty -- that is the other way round to matchExpectedPatTy | otherwise - = do { (_, tys, subst) <- tcInstTyVars tvs - ; wrap1 <- instCall PatOrigin tys (substTheta subst theta) + = do { (subst, tvs') <- tcInstTyVars tvs + ; wrap1 <- instCall PatOrigin (mkTyVarTys tvs') (substTheta subst theta) ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (TcType.substTy subst tau) - ; return (wrap2 <.> wrap1 , arg_tys) } + ; return (wrap2 <.> wrap1, arg_tys) } where (tvs, theta, tau) = tcSplitSigmaTy pat_ty @@ -868,7 +868,7 @@ matchExpectedConTy data_tc pat_ty | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc -- Comments refer to Note [Matching constructor patterns] -- co_tc :: forall a. T [a] ~ T7 a - = do { (_, tys, subst) <- tcInstTyVars (tyConTyVars data_tc) + = do { (subst, tvs') <- tcInstTyVars (tyConTyVars data_tc) -- tys = [ty1,ty2] ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, @@ -877,10 +877,11 @@ matchExpectedConTy data_tc pat_ty ; co1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty -- co1 : T (ty1,ty2) ~ pat_ty - ; let co2 = mkTcUnbranchedAxInstCo Nominal co_tc tys + ; let tys' = mkTyVarTys tvs' + co2 = mkTcUnbranchedAxInstCo Nominal co_tc tys' -- co2 : T (ty1,ty2) ~ T7 ty1 ty2 - ; return (mkTcSymCo co2 `mkTcTransCo` co1, tys) } + ; return (mkTcSymCo co2 `mkTcTransCo` co1, tys') } | otherwise = matchExpectedTyConApp data_tc pat_ty diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs index 9b2b5110f4..d27ab4fa8a 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -48,18 +48,23 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, psb_def = lpat, psb_dir = dir } = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat ; tcCheckPatSynPat lpat - ; pat_ty <- newFlexiTyVarTy openTypeKind + ; ; let (arg_names, is_infix) = case details of PrefixPatSyn names -> (map unLoc names, False) InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True) - ; ((lpat', args), wanted) <- captureConstraints $ - tcPat PatSyn lpat pat_ty $ - mapM tcLookupId arg_names - ; let named_taus = (name, pat_ty):map (\arg -> (getName arg, varType arg)) args + ; (((lpat', (args, pat_ty)), untch), wanted) + <- captureConstraints $ + captureUntouchables $ + do { pat_ty <- newFlexiTyVarTy openTypeKind + ; tcPat PatSyn lpat pat_ty $ + do { args <- mapM tcLookupId arg_names + ; return (args, pat_ty) } } + + ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args ; traceTc "tcPatSynDecl::wanted" (ppr named_taus $$ ppr wanted) - ; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer True False named_taus wanted + ; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer untch False named_taus wanted ; (ex_vars, prov_dicts) <- tcCollectEx lpat' ; let univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 8ec81188ea..3440b4ff3a 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1645,11 +1645,12 @@ tcRnExpr hsc_env rdr_expr -- it might have a rank-2 type (e.g. :t runST) uniq <- newUnique ; let { fresh_it = itName uniq (getLoc rdr_expr) } ; - ((_tc_expr, res_ty), lie) <- captureConstraints $ - tcInferRho rn_expr ; + (((_tc_expr, res_ty), untch), lie) <- captureConstraints $ + captureUntouchables $ + tcInferRho rn_expr ; ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ {-# SCC "simplifyInfer" #-} - simplifyInfer True {- Free vars are closed -} + simplifyInfer untch False {- No MR for now -} [(fresh_it, res_ty)] lie ; @@ -1919,7 +1920,7 @@ tcDump env -- Dump short output if -ddump-types or -ddump-tc when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn short_dump) ; + (printForUserTcRn short_dump) ; -- Dump bindings if -ddump-tc dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index bd6218c019..cd414999af 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -192,8 +192,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this lie <- readIORef lie_var ; if isEmptyWC lie then return () - else pprPanic "initTc: unsolved constraints" - (pprWantedsWithLocs lie) ; + else pprPanic "initTc: unsolved constraints" (ppr lie) ; -- Collect any error messages msgs <- readIORef errs_var ; @@ -487,25 +486,35 @@ traceIf = traceOptIf Opt_D_dump_if_trace traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs -traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything -traceOptIf flag doc = whenDOptM flag $ - do dflags <- getDynFlags - liftIO (printInfoForUser dflags alwaysQualify doc) +traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () +traceOptIf flag doc + = whenDOptM flag $ -- No RdrEnv available, so qualify everything + do { dflags <- getDynFlags + ; liftIO (putMsg dflags doc) } traceOptTcRn :: DumpFlag -> SDoc -> TcRn () -- Output the message, with current location if opt_PprStyle_Debug -traceOptTcRn flag doc = whenDOptM flag $ do - { loc <- getSrcSpanM - ; let real_doc - | opt_PprStyle_Debug = mkLocMessage SevInfo loc doc - | otherwise = doc -- The full location is - -- usually way too much - ; dumpTcRn real_doc } +traceOptTcRn flag doc + = whenDOptM flag $ + do { loc <- getSrcSpanM + ; let real_doc + | opt_PprStyle_Debug = mkLocMessage SevInfo loc doc + | otherwise = doc -- The full location is + -- usually way too much + ; dumpTcRn real_doc } dumpTcRn :: SDoc -> TcRn () -dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv - ; dflags <- getDynFlags - ; liftIO (printInfoForUser dflags (mkPrintUnqualified dflags rdr_env) doc) } +dumpTcRn doc + = do { dflags <- getDynFlags + ; rdr_env <- getGlobalRdrEnv + ; liftIO (logInfo dflags (mkDumpStyle (mkPrintUnqualified dflags rdr_env)) doc) } + +printForUserTcRn :: SDoc -> TcRn () +-- Like dumpTcRn, but for user consumption +printForUserTcRn doc + = do { dflags <- getDynFlags + ; rdr_env <- getGlobalRdrEnv + ; liftIO (printInfoForUser dflags (mkPrintUnqualified dflags rdr_env) doc) } debugDumpTcRn :: SDoc -> TcRn () debugDumpTcRn doc | opt_NoDebugOutput = return () @@ -698,14 +707,6 @@ reportWarning warn errs_var <- getErrsVar ; (warns, errs) <- readTcRef errs_var ; writeTcRef errs_var (warns `snocBag` warn, errs) } - -dumpDerivingInfo :: SDoc -> TcM () -dumpDerivingInfo doc - = do { dflags <- getDynFlags - ; when (dopt Opt_D_dump_deriv dflags) $ do - { rdr_env <- getGlobalRdrEnv - ; let unqual = mkPrintUnqualified dflags rdr_env - ; liftIO (putMsgWith dflags unqual doc) } } \end{code} @@ -824,6 +825,9 @@ checkNoErrs main Just val -> return val } +whenNoErrs :: TcM () -> TcM () +whenNoErrs thing = ifErrsM (return ()) thing + ifErrsM :: TcRn r -> TcRn r -> TcRn r -- ifErrsM bale_out normal -- does 'bale_out' if there are errors in errors collection @@ -1052,12 +1056,14 @@ newTcEvBinds = do { ref <- newTcRef emptyEvBindMap addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM () -- Add a binding to the TcEvBinds by side effect -addTcEvBind (EvBindsVar ev_ref _) var t - = do { bnds <- readTcRef ev_ref - ; writeTcRef ev_ref (extendEvBinds bnds var t) } +addTcEvBind (EvBindsVar ev_ref _) ev_id ev_tm + = do { traceTc "addTcEvBind" $ vcat [ text "ev_id =" <+> ppr ev_id + , text "ev_tm =" <+> ppr ev_tm ] + ; bnds <- readTcRef ev_ref + ; writeTcRef ev_ref (extendEvBinds bnds ev_id ev_tm) } getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind) -getTcEvBinds (EvBindsVar ev_ref _) +getTcEvBinds (EvBindsVar ev_ref _) = do { bnds <- readTcRef ev_ref ; return (evBindMapBinds bnds) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 86475e084e..cf1e851ed3 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -44,18 +44,19 @@ module TcRnTypes( ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, -- Canonical constraints - Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, dropDerivedWC, - singleCt, listToCts, ctsElts, extendCts, extendCtsList, + Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts, + singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, isEmptyCts, isCTyEqCan, isCFunEqCan, isCDictCan_Maybe, isCFunEqCan_maybe, isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, isGivenCt, isHoleCt, ctEvidence, ctLoc, ctPred, mkNonCanonical, mkNonCanonicalCt, - ctEvPred, ctEvTerm, ctEvId, ctEvCheckDepth, + ctEvPred, ctEvLoc, ctEvTerm, ctEvCoercion, ctEvId, ctEvCheckDepth, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols, + dropDerivedWC, Implication(..), SubGoalCounter(..), @@ -72,10 +73,9 @@ module TcRnTypes( CtEvidence(..), mkGivenLoc, isWanted, isGiven, isDerived, - canRewrite, canRewriteOrSame, -- Pretty printing - pprEvVarTheta, pprWantedsWithLocs, + pprEvVarTheta, pprEvVars, pprEvVarWithType, pprArising, pprArisingAt, @@ -984,9 +984,9 @@ type Cts = Bag Ct data Ct -- Atomic canonical constraints = CDictCan { -- e.g. Num xi - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_class :: Class, - cc_tyargs :: [Xi] + cc_tyargs :: [Xi] -- cc_tyargs are function-free, hence Xi } | CIrredEvCan { -- These stand for yet-unusable predicates @@ -998,26 +998,43 @@ data Ct -- See Note [CIrredEvCan constraints] } - | CTyEqCan { -- tv ~ xi (recall xi means function free) - -- Invariant: + | CTyEqCan { -- tv ~ rhs + -- Invariants: + -- * See Note [Applying the inert substitution] in TcFlatten -- * tv not in tvs(xi) (occurs check) - -- * typeKind xi `subKind` typeKind tv + -- * If tv is a TauTv, then rhs has no foralls + -- (this avoids substituting a forall for the tyvar in other types) + -- * typeKind ty `subKind` typeKind tv -- See Note [Kind orientation for CTyEqCan] - -- * We prefer unification variables on the left *JUST* for efficiency - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + -- * rhs is not necessarily function-free, + -- but it has no top-level function. + -- E.g. a ~ [F b] is fine + -- but a ~ F b is not + -- * If rhs is also a tv, then it is oriented to give best chance of + -- unification happening; eg if rhs is touchable then lhs is too + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_tyvar :: TcTyVar, - cc_rhs :: Xi + cc_rhs :: TcType -- Not necessarily function-free (hence not Xi) + -- See invariants above } - | CFunEqCan { -- F xis ~ xi - -- Invariant: * isSynFamilyTyCon cc_fun - -- * typeKind (F xis) `subKind` typeKind xi - -- See Note [Kind orientation for CFunEqCan] + | CFunEqCan { -- F xis ~ fsk + -- Invariants: + -- * isSynFamilyTyCon cc_fun + -- * typeKind (F xis) = tyVarKind fsk + -- * always Nominal role + -- * always Given or Wanted, never Derived cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_fun :: TyCon, -- A type function - cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated - cc_rhs :: Xi -- *never* over-saturated (because if so - -- we should have decomposed) + + cc_tyargs :: [Xi], -- cc_tyargs are function-free (hence Xi) + -- Either under-saturated or exactly saturated + -- *never* over-saturated (because if so + -- we should have decomposed) + + cc_fsk :: TcTyVar -- [Given] always a FlatSkol skolem + -- [Wanted] always a FlatMetaTv unification variable + -- See Note [The flattening story] in TcFlatten } | CNonCanonical { -- See Note [NonCanonical Semantics] @@ -1033,11 +1050,13 @@ data Ct Note [Kind orientation for CTyEqCan] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given an equality (t:* ~ s:Open), we absolutely want to re-orient it. -We can't solve it by updating t:=s, ragardless of how touchable 't' is, -because the kinds don't work. Indeed we don't want to leave it with -the orientation (t ~ s), because if that gets into the inert set we'll -start replacing t's by s's, and that too is the wrong way round. +Given an equality (t:* ~ s:Open), we can't solve it by updating t:=s, +ragardless of how touchable 't' is, because the kinds don't work. + +Instead we absolutely must re-orient it. Reason: if that gets into the +inert set we'll start replacing t's by s's, and that might make a +kind-correct type into a kind error. After re-orienting, +we may be able to solve by updating s:=t. Hence in a CTyEqCan, (t:k1 ~ xi:k2) we require that k2 is a subkind of k1. @@ -1114,7 +1133,7 @@ ctEvidence :: Ct -> CtEvidence ctEvidence = cc_ev ctLoc :: Ct -> CtLoc -ctLoc = ctev_loc . cc_ev +ctLoc = ctEvLoc . ctEvidence ctPred :: Ct -> PredType -- See Note [Ct/evidence invariant] @@ -1144,7 +1163,7 @@ comprehensible error. Particularly: * Insoluble derived wanted equalities (e.g. [D] Int ~ Bool) may arise from functional dependency interactions. We are careful - to keep a good CtOrigin on such constriants (FunDepOrigin1, FunDepOrigin2) + to keep a good CtOrigin on such constraints (FunDepOrigin1, FunDepOrigin2) so that we can produce a good error message (Trac #9612) Since we leave these Derived constraints in the residual WantedConstraints, @@ -1225,8 +1244,11 @@ listToCts = listToBag ctsElts :: Cts -> [Ct] ctsElts = bagToList -extendCts :: Cts -> Ct -> Cts -extendCts = snocBag +consCts :: Ct -> Cts -> Cts +consCts = consBag + +snocCts :: Cts -> Ct -> Cts +snocCts = snocBag extendCtsList :: Cts -> [Ct] -> Cts extendCtsList cts xs | null xs = cts @@ -1240,6 +1262,9 @@ emptyCts = emptyBag isEmptyCts :: Cts -> Bool isEmptyCts = isEmptyBag + +pprCts :: Cts -> SDoc +pprCts cts = vcat (map ppr (bagToList cts)) \end{code} %************************************************************************ @@ -1303,15 +1328,15 @@ addInsols wc cts instance Outputable WantedConstraints where ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n}) = ptext (sLit "WC") <+> braces (vcat - [ if isEmptyBag f then empty else - ptext (sLit "wc_flat =") <+> pprBag ppr f - , if isEmptyBag i then empty else - ptext (sLit "wc_impl =") <+> pprBag ppr i - , if isEmptyBag n then empty else - ptext (sLit "wc_insol =") <+> pprBag ppr n ]) - -pprBag :: (a -> SDoc) -> Bag a -> SDoc -pprBag pp b = foldrBag (($$) . pp) empty b + [ ppr_bag (ptext (sLit "wc_flat")) f + , ppr_bag (ptext (sLit "wc_insol")) n + , ppr_bag (ptext (sLit "wc_impl")) i ]) + +ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc +ppr_bag doc bag + | isEmptyBag bag = empty + | otherwise = hang (doc <+> equals) + 2 (foldrBag (($$) . ppr) empty bag) \end{code} @@ -1335,10 +1360,6 @@ data Implication -- (order does not matter) -- See Invariant (GivenInv) in TcType - ic_fsks :: [TcTyVar], -- Extra flatten-skolems introduced by - -- by flattening the givens - -- See Note [Given flatten-skolems] - ic_no_eqs :: Bool, -- True <=> ic_givens have no equalities, for sure -- False <=> ic_givens might have equalities @@ -1354,19 +1375,19 @@ data Implication } instance Outputable Implication where - ppr (Implic { ic_untch = untch, ic_skols = skols, ic_fsks = fsks + ppr (Implic { ic_untch = untch, ic_skols = skols , ic_given = given, ic_no_eqs = no_eqs - , ic_wanted = wanted + , ic_wanted = wanted, ic_insol = insol , ic_binds = binds, ic_info = info }) - = ptext (sLit "Implic") <+> braces - (sep [ ptext (sLit "Untouchables =") <+> ppr untch - , ptext (sLit "Skolems =") <+> pprTvBndrs skols - , ptext (sLit "Flatten-skolems =") <+> pprTvBndrs fsks - , ptext (sLit "No-eqs =") <+> ppr no_eqs - , ptext (sLit "Given =") <+> pprEvVars given - , ptext (sLit "Wanted =") <+> ppr wanted - , ptext (sLit "Binds =") <+> ppr binds - , pprSkolInfo info ]) + = hang (ptext (sLit "Implic") <+> lbrace) + 2 (sep [ ptext (sLit "Untouchables =") <+> ppr untch + , ptext (sLit "Skolems =") <+> pprTvBndrs skols + , ptext (sLit "No-eqs =") <+> ppr no_eqs + , ptext (sLit "Insol =") <+> ppr insol + , hang (ptext (sLit "Given =")) 2 (pprEvVars given) + , hang (ptext (sLit "Wanted =")) 2 (ppr wanted) + , ptext (sLit "Binds =") <+> ppr binds + , pprSkolInfo info ] <+> rbrace) \end{code} Note [Shadowing in a constraint] @@ -1437,12 +1458,6 @@ pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) pprEvVarWithType :: EvVar -> SDoc pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) - -pprWantedsWithLocs :: WantedConstraints -> SDoc -pprWantedsWithLocs wcs - = vcat [ pprBag ppr (wc_flat wcs) - , pprBag ppr (wc_impl wcs) - , pprBag ppr (wc_insol wcs) ] \end{code} %************************************************************************ @@ -1480,16 +1495,26 @@ ctEvPred :: CtEvidence -> TcPredType -- The predicate of a flavor ctEvPred = ctev_pred +ctEvLoc :: CtEvidence -> CtLoc +ctEvLoc = ctev_loc + ctEvTerm :: CtEvidence -> EvTerm ctEvTerm (CtGiven { ctev_evtm = tm }) = tm ctEvTerm (CtWanted { ctev_evar = ev }) = EvId ev ctEvTerm ctev@(CtDerived {}) = pprPanic "ctEvTerm: derived constraint cannot have id" (ppr ctev) +ctEvCoercion :: CtEvidence -> TcCoercion +-- ctEvCoercion ev = evTermCoercion (ctEvTerm ev) +ctEvCoercion (CtGiven { ctev_evtm = tm }) = evTermCoercion tm +ctEvCoercion (CtWanted { ctev_evar = v }) = mkTcCoVarCo v +ctEvCoercion ctev@(CtDerived {}) = pprPanic "ctEvCoercion: derived constraint cannot have id" + (ppr ctev) + -- | Checks whether the evidence can be used to solve a goal with the given minimum depth ctEvCheckDepth :: SubGoalDepth -> CtEvidence -> Bool ctEvCheckDepth _ (CtGiven {}) = True -- Given evidence has infinite depth -ctEvCheckDepth min ev@(CtWanted {}) = min <= ctLocDepth (ctev_loc ev) +ctEvCheckDepth min ev@(CtWanted {}) = min <= ctLocDepth (ctEvLoc ev) ctEvCheckDepth _ ev@(CtDerived {}) = pprPanic "ctEvCheckDepth: cannot consider derived evidence" (ppr ev) ctEvId :: CtEvidence -> TcId @@ -1514,49 +1539,8 @@ isGiven _ = False isDerived :: CtEvidence -> Bool isDerived (CtDerived {}) = True isDerived _ = False - ------------------------------------------ -canRewrite :: CtEvidence -> CtEvidence -> Bool --- Very important function! --- See Note [canRewrite and canRewriteOrSame] -canRewrite (CtGiven {}) _ = True -canRewrite (CtWanted {}) (CtDerived {}) = True -canRewrite (CtDerived {}) (CtDerived {}) = True -- Derived can't solve wanted/given -canRewrite _ _ = False -- No evidence for a derived, anyway - -canRewriteOrSame :: CtEvidence -> CtEvidence -> Bool -canRewriteOrSame (CtGiven {}) _ = True -canRewriteOrSame (CtWanted {}) (CtWanted {}) = True -canRewriteOrSame (CtWanted {}) (CtDerived {}) = True -canRewriteOrSame (CtDerived {}) (CtDerived {}) = True -canRewriteOrSame _ _ = False \end{code} -See Note [canRewrite and canRewriteOrSame] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(canRewrite ct1 ct2) holds if the constraint ct1 can be used to solve ct2. -"To solve" means a reaction where the active parts of the two constraints match. - active(F xis ~ xi) = F xis - active(tv ~ xi) = tv - active(D xis) = D xis - active(IP nm ty) = nm - -At the moment we don't allow Wanteds to rewrite Wanteds, because that can give -rise to very confusing type error messages. A good example is Trac #8450. -Here's another - f :: a -> Bool - f x = ( [x,'c'], [x,True] ) `seq` True -Here we get - [W] a ~ Char - [W] a ~ Bool -but we do not want to complain about Bool ~ Char! - -NB: either (a `canRewrite` b) or (b `canRewrite` a) - or a==b - must hold - -canRewriteOrSame is similar but returns True for Wanted/Wanted. -See the call sites for explanations. %************************************************************************ %* * @@ -1680,11 +1664,13 @@ data CtLoc = CtLoc { ctl_origin :: CtOrigin -- source location: tcl_loc :: SrcSpan -- context: tcl_ctxt :: [ErrCtxt] -- binder stack: tcl_bndrs :: [TcIdBinders] + -- level: tcl_untch :: Untouchables -mkGivenLoc :: SkolemInfo -> TcLclEnv -> CtLoc -mkGivenLoc skol_info env = CtLoc { ctl_origin = GivenOrigin skol_info - , ctl_env = env - , ctl_depth = initialSubGoalDepth } +mkGivenLoc :: Untouchables -> SkolemInfo -> TcLclEnv -> CtLoc +mkGivenLoc untch skol_info env + = CtLoc { ctl_origin = GivenOrigin skol_info + , ctl_env = env { tcl_untch = untch } + , ctl_depth = initialSubGoalDepth } ctLocEnv :: CtLoc -> TcLclEnv ctLocEnv = ctl_env @@ -1827,9 +1813,6 @@ pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "Unk \begin{code} data CtOrigin = GivenOrigin SkolemInfo - | FlatSkolOrigin -- Flatten-skolems created for Givens - -- Note [When does an implication have given equalities?] - -- in TcSimplify -- All the others are for *wanted* constraints | OccurrenceOf Name -- Occurrence of an overloaded identifier @@ -1888,7 +1871,6 @@ data CtOrigin | UnboundOccurrenceOf RdrName | ListOrigin -- An overloaded list - ctoHerald :: SDoc ctoHerald = ptext (sLit "arising from") @@ -1939,7 +1921,6 @@ pprCtOrigin simple_origin ---------------- pprCtO :: CtOrigin -> SDoc -- Ones that are short one-liners -pprCtO FlatSkolOrigin = ptext (sLit "a given flatten-skolem") pprCtO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] pprCtO AppOrigin = ptext (sLit "an application") pprCtO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)] diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index 3b405b3dda..f1d528f098 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -168,7 +168,6 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) ; rhs_binds_var <- newTcEvBinds ; emitImplication $ Implic { ic_untch = noUntouchables , ic_skols = qtkvs - , ic_fsks = [] , ic_no_eqs = False , ic_given = lhs_evs , ic_wanted = rhs_wanted @@ -183,7 +182,6 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) ; lhs_binds_var <- newTcEvBinds ; emitImplication $ Implic { ic_untch = noUntouchables , ic_skols = qtkvs - , ic_fsks = [] , ic_no_eqs = False , ic_given = lhs_evs , ic_wanted = other_lhs_wanted diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 034c7a8edc..4d910d9d3b 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -7,32 +7,30 @@ module TcSMonad ( -- Canonical constraints, definition is now in TcRnTypes WorkList(..), isEmptyWorkList, emptyWorkList, - workListFromEq, workListFromNonEq, workListFromCt, - extendWorkListEq, extendWorkListFunEq, + extendWorkListFunEq, extendWorkListNonEq, extendWorkListCt, - extendWorkListCts, extendWorkListEqs, appendWorkList, selectWorkItem, - withWorkList, workListSize, + extendWorkListCts, appendWorkList, selectWorkItem, + workListSize, - updWorkListTcS, updWorkListTcS_return, + updWorkListTcS, updWorkListTcS_return, getWorkListImplics, - updTcSImplics, + updInertCans, updInertDicts, updInertIrreds, updInertFunEqs, Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, - emitInsoluble, + emitInsoluble, emitWorkNC, isWanted, isDerived, isGivenCt, isWantedCt, isDerivedCt, - canRewrite, mkGivenLoc, TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality - traceFireTcS, bumpStepCountTcS, + traceFireTcS, bumpStepCountTcS, csTraceTcS, tryTcS, nestTcS, nestImplicTcS, recoverTcS, wrapErrTcS, wrapWarnTcS, -- Getting and setting the flattening cache - addSolvedDict, addSolvedFunEq, getGivenInfo, + addSolvedDict, -- Marking stuff as used addUsedRdrNamesTcS, @@ -41,14 +39,18 @@ module TcSMonad ( setEvBind, XEvTerm(..), - MaybeNew (..), isFresh, freshGoal, freshGoals, getEvTerm, getEvTerms, + Freshness(..), freshGoals, + + StopOrContinue(..), continueWith, stopWith, andWhenContinue, xCtEvidence, -- Transform a CtEvidence during a step rewriteEvidence, -- Specialized version of xCtEvidence for coercions rewriteEqEvidence, -- Yet more specialised, for equality coercions maybeSym, - newWantedEvVar, newWantedEvVarNC, newWantedEvVarNonrec, newDerived, + newTcEvBinds, newWantedEvVar, newWantedEvVarNC, newWantedEvVarNonrec, + newEvVar, newGivenEvVar, newDerived, + emitNewDerived, emitNewDerivedEq, instDFunConstraints, -- Creation of evidence variables @@ -56,37 +58,40 @@ module TcSMonad ( getInstEnvs, getFamInstEnvs, -- Getting the environments getTopEnv, getGblEnv, getTcEvBinds, getUntouchables, - getTcEvBindsMap, getTcSTyBindsMap, + getTcEvBindsMap, - lookupFlatEqn, newFlattenSkolem, -- Flatten skolems + lookupFlatCache, newFlattenSkolem, -- Flatten skolems -- Deque Deque(..), insertDeque, emptyDeque, -- Inerts InertSet(..), InertCans(..), - getInertEqs, - emptyInert, getTcSInerts, setTcSInerts, - getInertUnsolved, checkAllSolved, + getNoGivenEqs, setInertCans, getInertEqs, getInertCans, + emptyInert, getTcSInerts, setTcSInerts, + getUnsolvedInerts, checkAllSolved, prepareInertsForImplications, - addInertCan, insertInertItemTcS, + addInertCan, insertInertItemTcS, insertFunEq, EqualCtList, lookupSolvedDict, extendFlatCache, - findFunEq, findTyEqs, findDict, findDictsByClass, addDict, addDictsByClass, delDict, partitionDicts, - findFunEqsByTyCon, findFunEqs, addFunEq, replaceFunEqs, partitionFunEqs, + + findFunEq, findTyEqs, + findFunEqsByTyCon, findFunEqs, partitionFunEqs, + sizeFunEqMap, instDFunType, -- Instantiation newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS, - cloneMetaTyVar, + cloneMetaTyVar, demoteUnfilledFmv, - Untouchables, isTouchableMetaTyVarTcS, isFilledMetaTyVar_maybe, - zonkTyVarsAndFV, + Untouchables, isTouchableMetaTyVarTcS, + isFilledMetaTyVar_maybe, isFilledMetaTyVar, + zonkTyVarsAndFV, zonkTcType, zonkTcTyVar, zonkFlats, getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, - matchFam, + matchFam, checkWellStagedDFun, pprEq -- Smaller utils, re-exported from TcM -- TODO (DV): these are only really used in the @@ -122,11 +127,10 @@ import Name import RdrName (RdrName, GlobalRdrEnv) import RnEnv (addUsedRdrNames) import Var -import VarSet import VarEnv +import VarSet import Outputable import Bag -import MonadUtils import UniqSupply import FastString @@ -137,13 +141,13 @@ import TcRnTypes import BasicTypes import Unique import UniqFM -import Maybes ( orElse, catMaybes, firstJusts ) -import Pair ( pSnd ) +import Maybes ( orElse, firstJusts ) import TrieMap -import Control.Monad( ap, when ) +import Control.Monad( ap, when, unless ) +import MonadUtils import Data.IORef -import Data.List( partition ) +import Pair #ifdef DEBUG import Digraph @@ -172,26 +176,15 @@ is not strictly necessary. Notice that non-canonical constraints are also parts of the worklist. -Note [NonCanonical Semantics] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that canonical constraints involve a CNonCanonical constructor. In the worklist -we use this constructor for constraints that have not yet been canonicalized such as - [Int] ~ [a] -In other words, all constraints start life as NonCanonicals. - -On the other hand, in the Inert Set (see below) the presence of a NonCanonical somewhere -means that we have a ``frozen error''. - -NonCanonical constraints never interact directly with other constraints -- but they can -be rewritten by equalities (for instance if a non canonical exists in the inert, we'd -better rewrite it as much as possible before reporting it as an error to the user) - \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 instance Outputable a => Outputable (Deque a) where - ppr (DQ as bs) = ppr (as ++ reverse bs) -- Show first one to come out at the start + ppr q = ppr (dequeList q) + +dequeList :: Deque a -> [a] +dequeList (DQ as bs) = as ++ reverse bs -- First one to come out at the start emptyDeque :: Deque a emptyDeque = DQ [] [] @@ -216,75 +209,72 @@ extractDeque (DQ [] bs) = case reverse bs of [] -> panic "extractDeque" -- See Note [WorkList priorities] -data WorkList = WorkList { wl_eqs :: [Ct] - , wl_funeqs :: Deque Ct - , wl_rest :: [Ct] - } - +data WorkList + = WL { wl_eqs :: [Ct] + , wl_funeqs :: Deque Ct + , wl_rest :: [Ct] + , wl_implics :: Bag Implication -- See Note [Residual implications] + } appendWorkList :: WorkList -> WorkList -> WorkList -appendWorkList new_wl orig_wl - = WorkList { wl_eqs = wl_eqs new_wl ++ wl_eqs orig_wl - , wl_funeqs = wl_funeqs new_wl `appendDeque` wl_funeqs orig_wl - , wl_rest = wl_rest new_wl ++ wl_rest orig_wl } +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 + , wl_funeqs = funeqs1 `appendDeque` funeqs2 + , wl_rest = rest1 ++ rest2 + , wl_implics = implics1 `unionBags` implics2 } workListSize :: WorkList -> Int -workListSize (WorkList { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest }) +workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest }) = length eqs + dequeSize funeqs + length rest extendWorkListEq :: Ct -> WorkList -> WorkList --- Extension by equality -extendWorkListEq ct wl - | Just {} <- isCFunEqCan_maybe ct - = extendWorkListFunEq ct wl - | otherwise +extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl } extendWorkListFunEq :: Ct -> WorkList -> WorkList extendWorkListFunEq ct wl = wl { wl_funeqs = insertDeque ct (wl_funeqs wl) } -extendWorkListEqs :: [Ct] -> WorkList -> WorkList --- Append a list of equalities -extendWorkListEqs cts wl = foldr extendWorkListEq wl cts - extendWorkListNonEq :: Ct -> WorkList -> WorkList -- Extension by non equality extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } +extendWorkListImplic :: Implication -> WorkList -> WorkList +extendWorkListImplic implic wl + = wl { wl_implics = implic `consBag` wl_implics wl } + extendWorkListCt :: Ct -> WorkList -> WorkList -- Agnostic extendWorkListCt ct wl - | isEqPred (ctPred ct) = extendWorkListEq ct wl - | otherwise = extendWorkListNonEq ct wl + = case classifyPredType (ctPred ct) of + EqPred ty1 _ + | Just (tc,_) <- tcSplitTyConApp_maybe ty1 + , isSynFamilyTyCon tc + -> extendWorkListFunEq ct wl + | otherwise + -> extendWorkListEq ct wl + + _ -> extendWorkListNonEq ct wl extendWorkListCts :: [Ct] -> WorkList -> WorkList -- Agnostic extendWorkListCts cts wl = foldr extendWorkListCt wl cts isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList wl - = null (wl_eqs wl) && null (wl_rest wl) && isEmptyDeque (wl_funeqs wl) +isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs + , wl_rest = rest, wl_implics = implics }) + = null eqs && null rest && isEmptyDeque funeqs && isEmptyBag implics emptyWorkList :: WorkList -emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = emptyDeque } - -workListFromEq :: Ct -> WorkList -workListFromEq ct = extendWorkListEq ct emptyWorkList - -workListFromNonEq :: Ct -> WorkList -workListFromNonEq ct = extendWorkListNonEq ct emptyWorkList - -workListFromCt :: Ct -> WorkList --- Agnostic -workListFromCt ct | isEqPred (ctPred ct) = workListFromEq ct - | otherwise = workListFromNonEq ct - +emptyWorkList = WL { wl_eqs = [], wl_rest = [] + , wl_funeqs = emptyDeque, wl_implics = emptyBag } selectWorkItem :: WorkList -> (Maybe Ct, WorkList) -selectWorkItem wl@(WorkList { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest }) +selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest }) = case (eqs,feqs,rest) of (ct:cts,_,_) -> (Just ct, wl { wl_eqs = cts }) (_,fun_eqs,_) | Just (fun_eqs', ct) <- extractDeque fun_eqs @@ -294,10 +284,18 @@ selectWorkItem wl@(WorkList { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest }) -- Pretty printing instance Outputable WorkList where - ppr wl = vcat [ text "WorkList (eqs) = " <+> ppr (wl_eqs wl) - , text "WorkList (funeqs)= " <+> ppr (wl_funeqs wl) - , text "WorkList (rest) = " <+> ppr (wl_rest wl) - ] + ppr (WL { wl_eqs = eqs, wl_funeqs = feqs + , wl_rest = rest, wl_implics = implics }) + = text "WL" <+> (braces $ + vcat [ ppUnless (null eqs) $ + ptext (sLit "Eqs =") <+> vcat (map ppr eqs) + , ppUnless (isEmptyDeque feqs) $ + ptext (sLit "Funeqs =") <+> vcat (map ppr (dequeList feqs)) + , ppUnless (null rest) $ + ptext (sLit "Eqs =") <+> vcat (map ppr rest) + , ppUnless (isEmptyBag implics) $ + ptext (sLit "Implics =") <+> vcat (map ppr (bagToList implics)) + ]) \end{code} %************************************************************************ @@ -335,14 +333,14 @@ The InertCans represents a collection of constraints with the following properti apply the substitution /recursively/ to the types involved. Currently the one AND ONLY way in the whole constraint solver that we rewrite types and constraints wrt - to the inert substitution is TcCanonical/flattenTyVar. + to the inert substitution is TcFlatten/flattenTyVar. - In the past we did try to have the inert substitution as idempotent as possible but this would only be true for constraints of the same flavor, so in total the inert substitution could not be idempotent, due to flavor-related - issued. Note [Non-idempotent inert substitution] explains - what is going on. + issued. Note [Non-idempotent inert substitution] in TcFlatten + explains what is going on. - Whenever a constraint ends up in the worklist we do recursively apply exhaustively the inert substitution to it @@ -356,29 +354,9 @@ The InertCans represents a collection of constraints with the following properti equalities can safely stay in the inert set and which must be kicked out to be rewritten and re-checked for occurs errors. - -Note [Solved constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~ -When we take a step to simplify a constraint 'c', we call the original constraint "solved". -For example: Wanted: ev :: [s] ~ [t] - New goal: ev1 :: s ~ t - Then 'ev' is now "solved". - -The reason for all this is simply to avoid re-solving goals we have solved already. - -* A solved Wanted may depend on as-yet-unsolved goals, so (for example) we should not - use it to rewrite a Given; in that sense the solved goal is still a Wanted - -* A solved Given is just given - -* A solved Derived in inert_solved is possible; purpose is to avoid - creating tons of identical Derived goals. - - But there are no solved Deriveds in inert_solved_funeqs - Note [Type family equations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type-family equations, of form (ev : F tys ~ ty), live in four places +Type-family equations, of form (ev : F tys ~ ty), live in three places * The work-list, of course @@ -393,12 +371,8 @@ Type-family equations, of form (ev : F tys ~ ty), live in four places a top-level goal. Eg in the above example we don't want to solve w3 using w3 itself! - * The inert_solved_funeqs. These are all "solved" goals (see Note [Solved constraints]), - the result of using a top-level type-family instance. - * 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 @@ -408,7 +382,7 @@ data InertCans -- Some Refl equalities are also in tcs_ty_binds -- see Note [Spontaneously solved in TyBinds] in TcInteract - , inert_funeqs :: FunEqMap EqualCtList + , inert_funeqs :: FunEqMap Ct -- All CFunEqCans; index is the whole family head type. , inert_dicts :: DictMap Ct @@ -421,13 +395,6 @@ data InertCans , inert_insols :: Cts -- Frozen errors (as non-canonicals) - - , inert_no_eqs :: !Bool - -- Set to False when adding a new equality - -- (eq/funeq) or potential equality (irred) - -- whose evidence is not a constant - -- See Note [When does an implication have given equalities?] - -- in TcSimplify } type EqualCtList = [Ct] @@ -448,8 +415,10 @@ data InertSet -- Canonical Given, Wanted, Derived (no Solved) -- Sometimes called "the inert set" - , inert_flat_cache :: FunEqMap (CtEvidence, TcType) + , inert_flat_cache :: FunEqMap (TcCoercion, TcTyVar) -- See Note [Type family equations] + -- 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 -- them to solve a top-level goal, else you may end up solving @@ -457,17 +426,6 @@ data InertSet -- when allocating a new flatten-skolem. -- Not necessarily inert wrt top-level equations (or inert_cans) - , inert_fsks :: [TcTyVar] -- Rigid flatten-skolems (arising from givens) - -- allocated in this local scope - -- See Note [Given flatten-skolems] - - , inert_solved_funeqs :: FunEqMap (CtEvidence, TcType) - -- See Note [Type family equations] - -- Of form co :: F xis ~ xi - -- Always the result of using a top-level family axiom F xis ~ tau - -- No Deriveds - -- Not necessarily fully rewritten (by type substitutions) - , inert_solved_dicts :: DictMap CtEvidence -- Of form ev :: C t1 .. tn -- Always the result of using a top-level instance declaration @@ -479,33 +437,12 @@ data InertSet } \end{code} -Note [Given flatten-skolems] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we simplify the implication - forall b. C (F a) b => (C (F a) beta, blah) -We'll flatten the givens, introducing a flatten-skolem, so the -givens effectively look like - (C fsk b, F a ~ fsk) -Then we simplify the wanteds, transforming (C (F a) beta) to (C fsk beta). -Now, if we don't solve that wanted, we'll put it back into the residual -implication. But where is fsk bound? - -We solve this by recording the given flatten-skolems in the implication -(the ic_fsks field), so it's as if we change the implication to - forall b, fsk. (C fsk b, F a ~ fsk) => (C fsk beta, blah) - -We don't need to explicitly record the (F a ~ fsk) constraint in the implication -because we can recover it from inside the fsk TyVar itself. But we do need -to treat that (F a ~ fsk) as a new given. See the fsk_bag stuff in -TcInteract.solveInteractGiven. - \begin{code} instance Outputable InertCans where ppr ics = vcat [ ptext (sLit "Equalities:") <+> vcat (map ppr (varEnvElts (inert_eqs ics))) , ptext (sLit "Type-function equalities:") <+> vcat (map ppr (funEqsToList (inert_funeqs ics))) - , ptext (sLit "No-eqs:") <+> ppr (inert_no_eqs ics) , ptext (sLit "Dictionaries:") <+> vcat (map ppr (Bag.bagToList $ dictsToBag (inert_dicts ics))) , ptext (sLit "Irreds:") @@ -516,8 +453,7 @@ instance Outputable InertCans where instance Outputable InertSet where ppr is = vcat [ ppr $ inert_cans is - , text "Solved dicts" <+> int (sizeDictMap (inert_solved_dicts is)) - , text "Solved funeqs" <+> int (sizeFunEqMap (inert_solved_funeqs is))] + , text "Solved dicts" <+> int (sizeDictMap (inert_solved_dicts is)) ] emptyInert :: InertSet emptyInert @@ -526,31 +462,23 @@ emptyInert , inert_funeqs = emptyFunEqs , inert_irreds = emptyCts , inert_insols = emptyCts - , inert_no_eqs = True -- See Note [inert_fsks and inert_no_eqs] } - , inert_fsks = [] -- See Note [inert_fsks and inert_no_eqs] , inert_flat_cache = emptyFunEqs - , inert_solved_funeqs = emptyFunEqs , inert_solved_dicts = emptyDictMap } --------------- addInertCan :: InertCans -> Ct -> InertCans -- Precondition: item /is/ canonical -addInertCan ics item@(CTyEqCan { cc_ev = ev }) +addInertCan ics item@(CTyEqCan {}) = ics { inert_eqs = extendVarEnv_C (\eqs _ -> item : eqs) (inert_eqs ics) - (cc_tyvar item) [item] - , inert_no_eqs = isFlatSkolEv ev && inert_no_eqs ics } - -- See Note [When does an implication have given equalities?] in TcSimplify + (cc_tyvar item) [item] } -addInertCan ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys, cc_ev = ev }) - = ics { inert_funeqs = addFunEq (inert_funeqs ics) tc tys item - , inert_no_eqs = isFlatSkolEv ev && inert_no_eqs ics } - -- See Note [When does an implication have given equalities?] in TcSimplify +addInertCan ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) + = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item } addInertCan ics item@(CIrredEvCan {}) - = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item - , inert_no_eqs = False } + = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item } -- The 'False' is because the irreducible constraint might later instantiate -- to an equality. -- But since we try to simplify first, if there's a constraint function FC with @@ -565,14 +493,6 @@ addInertCan _ item ppr item -- Can't be CNonCanonical, CHoleCan, -- because they only land in inert_insols -isFlatSkolEv :: CtEvidence -> Bool --- True if (a) it's a Given and (b) it is evidence for --- (or derived from) a flatten-skolem equality. --- See Note [When does an implication have given equalities?] in TcSimplify -isFlatSkolEv ev = case ctLocOrigin (ctev_loc ev) of - FlatSkolOrigin -> True - _ -> False - -------------- insertInertItemTcS :: Ct -> TcS () -- Add a new item in the inerts of the monad @@ -580,7 +500,7 @@ insertInertItemTcS item = do { traceTcS "insertInertItemTcS {" $ text "Trying to insert new inert item:" <+> ppr item - ; updInertTcS (\ics -> ics { inert_cans = addInertCan (inert_cans ics) item }) + ; updInertCans (\ics -> addInertCan ics item) ; traceTcS "insertInertItemTcS }" $ empty } @@ -594,102 +514,85 @@ addSolvedDict item cls tys ; updInertTcS $ \ ics -> ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } } -addSolvedFunEq :: TyCon -> [TcType] -> CtEvidence -> TcType -> TcS () -addSolvedFunEq fam_tc tys ev rhs_ty - = updInertTcS $ \ inert -> - inert { inert_solved_funeqs = insertFunEq (inert_solved_funeqs inert) - fam_tc tys (ev, rhs_ty) } - updInertTcS :: (InertSet -> InertSet) -> TcS () -- Modify the inert set with the supplied function -updInertTcS upd +updInertTcS upd_fn = do { is_var <- getTcSInertsRef ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var - ; TcM.writeTcRef is_var (upd curr_inert) }) } + ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } -prepareInertsForImplications :: InertSet -> InertSet +getInertCans :: TcS InertCans +getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) } + +setInertCans :: InertCans -> TcS () +setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics } + +updInertCans :: (InertCans -> InertCans) -> TcS () +-- Modify the inert set with the supplied function +updInertCans upd_fn + = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } + +updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS () +-- Modify the inert set with the supplied function +updInertDicts upd_fn + = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) } + +updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS () +-- Modify the inert set with the supplied function +updInertFunEqs upd_fn + = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) } + +updInertIrreds :: (Cts -> Cts) -> TcS () +-- Modify the inert set with the supplied function +updInertIrreds upd_fn + = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) } + + +prepareInertsForImplications :: InertSet -> (InertSet) -- See Note [Preparing inert set for implications] -prepareInertsForImplications is - = is { inert_cans = getGivens (inert_cans is) - , inert_fsks = [] - , inert_flat_cache = emptyFunEqs } +prepareInertsForImplications is@(IS { inert_cans = cans }) + = is { inert_cans = getGivens cans + , inert_flat_cache = emptyFunEqs } -- See Note [Do not inherit the flat cache] where getGivens (IC { inert_eqs = eqs , inert_irreds = irreds , inert_funeqs = funeqs , inert_dicts = dicts }) - = IC { inert_eqs = filterVarEnv is_given_eq eqs - , inert_funeqs = foldFunEqs given_from_wanted funeqs emptyFunEqs + = IC { inert_eqs = filterVarEnv is_given_ecl eqs + , inert_funeqs = filterFunEqs isGivenCt funeqs , inert_irreds = Bag.filterBag isGivenCt irreds - , inert_dicts = filterDicts isGivenCt dicts - , inert_insols = emptyCts - , inert_no_eqs = True -- See Note [inert_fsks and inert_no_eqs] - } - - is_given_eq :: [Ct] -> Bool - is_given_eq (ct:rest) | isGivenCt ct = ASSERT( null rest ) True - is_given_eq _ = False - - given_from_wanted :: EqualCtList -> FunEqMap EqualCtList -> FunEqMap EqualCtList - given_from_wanted (funeq:_) fhm -- This is where the magic processing happens - -- for type-function equalities - -- Pick just the first - -- See Note [Preparing inert set for implications] - - | isWanted ev = insert_one (funeq { cc_ev = given_ev }) fhm - | isGiven ev = insert_one funeq fhm - where - ev = ctEvidence funeq - given_ev = CtGiven { ctev_evtm = EvId (ctev_evar ev) - , ctev_pred = ctev_pred ev - , ctev_loc = ctev_loc ev } - - given_from_wanted _ fhm = fhm -- Drop derived constraints + , inert_dicts = filterDicts isGivenCt dicts + , inert_insols = emptyCts } - insert_one :: Ct -> FunEqMap EqualCtList -> FunEqMap EqualCtList - insert_one item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) fhm - = addFunEq fhm tc tys item - insert_one item _ = pprPanic "insert_one" (ppr item) + 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 +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 +do that flattening recursively. + Note [Preparing inert set for implications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before solving the nested implications, we trim the inert set, retaining only Givens. These givens can be used when solving the inner implications. -With one wrinkle! We take all *wanted* *funeqs*, and turn them into givens. -Consider (Trac #4935) - type instance F True a b = a - type instance F False a b = b - - [w] F c a b ~ gamma - (c ~ True) => a ~ gamma - (c ~ False) => b ~ gamma - -Obviously this is soluble with gamma := F c a b. But -Since solveCTyFunEqs happens at the very end of solving, the only way -to solve the two implications is temporarily consider (F c a b ~ gamma) -as Given and push it inside the implications. Now, when we come -out again at the end, having solved the implications solveCTyFunEqs -will solve this equality. - -Turning type-function equalities into Givens is easy becase they -*stay inert*. No need to re-process them. - -We don't try to turn any *other* Wanteds into Givens: - - * For example, we should not push given dictionaries in because - of example LongWayOverlapping.hs, where we might get strange - overlap errors between far-away constraints in the program. - -There might be cases where interactions between wanteds can help -to solve a constraint. For example +There might be cases where interactions between wanteds at different levels +could help to solve a constraint. For example class C a b | a -> b (C Int alpha), (forall d. C d blah => C Int a) -If we push the (C Int alpha) inwards, as a given, it can produce a +If we pushed the (C Int alpha) inwards, as a given, it can produce a fundep (alpha~a) and this can float out again and be used to fix alpha. (In general we can't float class constraints out just in case (C d blah) might help to solve (C Int a).) But we ignore this possiblity. @@ -698,36 +601,137 @@ 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 [Ct]) +getInertEqs :: TcS (TyVarEnv EqualCtList) getInertEqs = do { inert <- getTcSInerts ; return (inert_eqs (inert_cans inert)) } -getInertUnsolved :: TcS (Cts, Cts) --- Return (unsolved-wanteds, insolubles) --- Both consist of a mixture of Wanted and Derived -getInertUnsolved - = do { is <- getTcSInerts - - ; let icans = inert_cans is - unsolved_irreds = Bag.filterBag is_unsolved (inert_irreds icans) - unsolved_dicts = foldDicts add_if_unsolved (inert_dicts icans) emptyCts - unsolved_funeqs = foldFunEqs add_if_unsolveds (inert_funeqs icans) emptyCts - unsolved_eqs = foldVarEnv add_if_unsolveds emptyCts (inert_eqs icans) - - unsolved_flats = unsolved_eqs `unionBags` unsolved_irreds `unionBags` - unsolved_dicts `unionBags` unsolved_funeqs - - ; return (unsolved_flats, inert_insols icans) } +getUnsolvedInerts :: TcS ( Cts -- Tyvar eqs: a ~ ty + , Cts -- Fun eqs: F a ~ ty + , Cts -- Insoluble + , Cts ) -- All others +getUnsolvedInerts + = do { IC { inert_eqs = tv_eqs, inert_funeqs = fun_eqs + , inert_irreds = irreds, inert_dicts = idicts + , inert_insols = insols } <- getInertCans + + ; let unsolved_tv_eqs = foldVarEnv (\cts rest -> foldr add_if_unsolved rest cts) + emptyCts tv_eqs + unsolved_fun_eqs = foldFunEqs add_if_unsolved fun_eqs emptyCts + unsolved_irreds = Bag.filterBag is_unsolved irreds + unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts + others = unsolved_irreds `unionBags` unsolved_dicts + + ; return ( unsolved_tv_eqs, unsolved_fun_eqs, insols, others) } + -- Keep even the given insolubles + -- so that we can report dead GADT pattern match branches where add_if_unsolved :: Ct -> Cts -> Cts - add_if_unsolved ct cts | is_unsolved ct = cts `extendCts` ct + add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts | otherwise = cts - add_if_unsolveds :: [Ct] -> Cts -> Cts - add_if_unsolveds eqs cts = foldr add_if_unsolved cts eqs - is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived +getNoGivenEqs :: Untouchables -- Untouchables of this implication + -> [TcTyVar] -- Skolems of this implication + -> TcS Bool -- True <=> definitely no residual given equalities +-- See Note [When does an implication have given equalities?] +getNoGivenEqs untch skol_tvs + = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = iirreds, inert_funeqs = funeqs }) + <- getInertCans + ; let local_fsks = foldFunEqs add_fsk funeqs emptyVarSet + + has_given_eqs = foldrBag ((||) . ev_given_here . ctEvidence) False iirreds + || foldVarEnv ((||) . eqs_given_here local_fsks) False ieqs + + ; traceTcS "getNoGivenEqs" (vcat [ppr has_given_eqs, ppr inerts]) + ; return (not has_given_eqs) } + where + eqs_given_here :: VarSet -> EqualCtList -> Bool + eqs_given_here local_fsks [CTyEqCan { cc_tyvar = tv, cc_ev = ev }] + -- Givens are always a sigleton + = not (skolem_bound_here local_fsks tv) && ev_given_here ev + eqs_given_here _ _ = False + + ev_given_here :: CtEvidence -> Bool + -- True for a Given bound by the curent implication, + -- i.e. the current level + ev_given_here ev + = isGiven ev + && untch == tcl_untch (ctl_env (ctEvLoc ev)) + + add_fsk :: Ct -> VarSet -> VarSet + add_fsk ct fsks | CFunEqCan { cc_fsk = tv, cc_ev = ev } <- ct + , isGiven ev = extendVarSet fsks tv + | otherwise = fsks + + skol_tv_set = mkVarSet skol_tvs + skolem_bound_here local_fsks tv -- See Note [Let-bound skolems] + = case tcTyVarDetails tv of + 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 + beta => alpha ~ Int +where beta is a unification variable that has already been unified +to () in an outer scope. Then we can float the (alpha ~ Int) out +just fine. So when deciding whether the givens contain an equality, +we should canonicalise first, rather than just looking at the original +givens (Trac #8644). + +So we simply look at the inert, canonical Givens and see if there are +any equalities among them, the calculation of has_given_eqs. There +are some wrinkles: + + * We must know which ones are bound in *this* implication and which + are bound further out. We can find that out from the Untouchable + level of the Given, which is itself recorded in the tcl_untch field + of the TcLclEnv stored in the Given (ev_given_here). + + What about interactions between inner and outer givens? + - Outer given is rewritten by an inner given, then there must + have been an inner given equality, hence the “given-eq” flag + will be true anyway. + + - Inner given rewritten by outer, retains its level (ie. The inner one) + + * We must take account of *potential* equalities, like the one above: + beta => ...blah... + If we still don't know what beta is, we conservatively treat it as potentially + becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs. + + * When flattening givens, we generate Given equalities like + <F [a]> : F [a] ~ f, + with Refl evidence, and we *don't* want those to count as an equality + in the givens! After all, the entire flattening business is just an + internal matter, and the evidence does not mention any of the 'givens' + of this implication. So we do not treat inert_funeqs as a 'given equality'. + + * See Note [Let-bound skolems] for another wrinkle + +Note [Let-bound skolems] +~~~~~~~~~~~~~~~~~~~~~~~~ +If * the inert set contains a canonical Given CTyEqCan (a ~ ty) +and * 'a' is a skolem bound in this very implication, b + +then: +a) The Given is pretty much a let-binding, like + f :: (a ~ b->c) => a -> a + Here the equality constraint is like saying + let a = b->c in ... + It is not adding any new, local equality information, + and hence can be ignored by has_given_eqs + +b) 'a' will have been completely substituted out in the inert set, + so we can safely discard it. Notably, it doesn't need to be + returned as part of 'fsks' + +For an example, see Trac #9211. + +\begin{code} checkAllSolved :: TcS Bool -- True if there are no unsolved wanteds -- Ignore Derived for this purpose, unless in insolubles @@ -736,28 +740,29 @@ checkAllSolved ; let icans = inert_cans is unsolved_irreds = Bag.anyBag isWantedCt (inert_irreds icans) - unsolved_dicts = foldDicts ((||) . isWantedCt) (inert_dicts icans) False - unsolved_funeqs = foldFunEqs ((||) . any isWantedCt) (inert_funeqs icans) False + unsolved_dicts = foldDicts ((||) . isWantedCt) (inert_dicts icans) False + unsolved_funeqs = foldFunEqs ((||) . isWantedCt) (inert_funeqs icans) False unsolved_eqs = foldVarEnv ((||) . any isWantedCt) False (inert_eqs icans) ; return (not (unsolved_eqs || unsolved_irreds || unsolved_dicts || unsolved_funeqs || not (isEmptyBag (inert_insols icans)))) } -lookupFlatEqn :: TyCon -> [Type] -> TcS (Maybe (CtEvidence, TcType)) -lookupFlatEqn fam_tc tys - = do { IS { inert_solved_funeqs = solved_funeqs - , inert_flat_cache = flat_cache +lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcTyVar)) +lookupFlatCache fam_tc tys + = do { IS { inert_flat_cache = flat_cache , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts - ; return (firstJusts [findFunEq solved_funeqs fam_tc tys, - lookup_inerts inert_funeqs, - findFunEq flat_cache fam_tc tys]) } + ; return (firstJusts [lookup_inerts inert_funeqs, + lookup_flats flat_cache]) } where lookup_inerts inert_funeqs - | (ct:_) <- findFunEqs inert_funeqs fam_tc tys - = Just (ctEvidence ct, cc_rhs ct) - | otherwise - = Nothing + | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk }) + <- findFunEqs inert_funeqs fam_tc tys + = Just (ctEvCoercion ctev, fsk) + | otherwise = Nothing + + lookup_flats flat_cache = findFunEq flat_cache fam_tc tys + lookupInInerts :: TcPredType -> TcS (Maybe CtEvidence) -- Is this exact predicate type cached in the solved or canonicals of the InertSet? @@ -768,30 +773,12 @@ lookupInInerts pty ; return $ case (classifyPredType pty) of ClassPred cls tys | Just ctev <- findDict solved_dicts cls tys - -- I'm not sure why we check for solved dicts, - -- but not for solved funeqs -> Just ctev | Just ct <- findDict (inert_dicts inert_cans) cls tys -> Just (ctEvidence ct) - EqPred ty1 _ty2 - | Just tv <- getTyVar_maybe ty1 -- Tyvar equation - -> foldr exact_match Nothing (findTyEqs (inert_eqs inert_cans) tv) - - | Just (tc, tys) <- splitTyConApp_maybe ty1 -- Family equation - -> foldr exact_match Nothing (findFunEqs (inert_funeqs inert_cans) tc tys) - - IrredPred {} -> foldrBag exact_match Nothing (inert_irreds inert_cans) - - _other -> Nothing -- NB: No caching for IPs or holes + _other -> Nothing -- NB: No caching for equalities, IPs, holes, or errors } - where - exact_match :: Ct -> Maybe CtEvidence -> Maybe CtEvidence - exact_match ct deflt | let ctev = ctEvidence ct - , ctEvPred ctev `tcEqType` pty - = Just ctev - | otherwise - = deflt lookupSolvedDict :: InertSet -> Class -> [Type] -> Maybe CtEvidence -- Returns just if exactly this predicate type exists in the solved. @@ -840,6 +827,23 @@ insertTcApp m cls tys ct = alterUFM alter_tm m cls where alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) +-- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b +-- mapTcApp f = mapUFM (mapTM f) + +filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct +filterTcAppMap f m + = mapUFM do_tm m + where + do_tm tm = foldTM insert_mb tm emptyTM + insert_mb ct tm + | f ct = insertTM tys ct tm + | otherwise = tm + where + tys = case ct of + CFunEqCan { cc_tyargs = tys } -> tys + CDictCan { cc_tyargs = tys } -> tys + _ -> pprPanic "filterTcAppMap" (ppr ct) + tcAppMapToBag :: TcAppMap a -> Bag a tcAppMapToBag m = foldTcAppMap consBag m emptyBag @@ -877,13 +881,7 @@ addDictsByClass m cls items add ct _ = pprPanic "addDictsByClass" (ppr ct) filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct -filterDicts f m = mapUFM do_tm m - where - do_tm tm = foldTM insert_mb tm emptyTM - insert_mb ct@(CDictCan { cc_tyargs = tys }) tm - | f ct = insertTM tys ct tm - | otherwise = tm - insert_mb ct _ = pprPanic "filterDicts" (ppr ct) +filterDicts f m = filterTcAppMap f m partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct) partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts) @@ -915,51 +913,44 @@ sizeFunEqMap m = foldFunEqs (\ _ x -> x+1) m 0 findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a findFunEq m tc tys = findTcApp m (getUnique tc) tys -findFunEqs :: FunEqMap [a] -> TyCon -> [Type] -> [a] -findFunEqs m tc tys = findTcApp m (getUnique tc) tys `orElse` [] +findFunEqs :: FunEqMap a -> TyCon -> [Type] -> Maybe a +findFunEqs m tc tys = findTcApp m (getUnique tc) tys -funEqsToList :: FunEqMap [a] -> [a] -funEqsToList m = foldTcAppMap (++) m [] +funEqsToList :: FunEqMap a -> [a] +funEqsToList m = foldTcAppMap (:) m [] -findFunEqsByTyCon :: FunEqMap [a] -> TyCon -> [a] +findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a] -- Get inert function equation constraints that have the given tycon -- in their head. Not that the constraints remain in the inert set. -- We use this to check for derived interactions with built-in type-function -- constructors. findFunEqsByTyCon m tc - | Just tm <- lookupUFM m tc = foldTM (++) tm [] + | Just tm <- lookupUFM m tc = foldTM (:) tm [] | otherwise = [] foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b foldFunEqs = foldTcAppMap +-- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b +-- mapFunEqs = mapTcApp + +filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct +filterFunEqs = filterTcAppMap + insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val -addFunEq :: FunEqMap EqualCtList -> TyCon -> [Type] -> Ct -> FunEqMap EqualCtList -addFunEq m tc tys item - = alterUFM alter_tm m (getUnique tc) - where - alter_tm mb_tm = Just (alterTM tys alter_cts (mb_tm `orElse` emptyTM)) - alter_cts Nothing = Just [item] - alter_cts (Just funeqs) = Just (item : funeqs) - -replaceFunEqs :: FunEqMap EqualCtList -> TyCon -> [Type] -> Ct -> FunEqMap EqualCtList -replaceFunEqs m tc tys ct = insertTcApp m (getUnique tc) tys [ct] +insertFunEqCt :: FunEqMap Ct -> Ct -> FunEqMap Ct +insertFunEqCt m ct@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) + = insertFunEq m tc tys ct +insertFunEqCt _ ct = pprPanic "insertFunEqCt" (ppr ct) -partitionFunEqs :: (Ct -> Bool) -> FunEqMap EqualCtList -> (Bag Ct, FunEqMap EqualCtList) +partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> (Bag Ct, FunEqMap Ct) partitionFunEqs f m = foldTcAppMap k m (emptyBag, emptyFunEqs) where - k cts (yeses, noes) - = ( case eqs_out of - [] -> yeses - _ -> yeses `unionBags` listToBag eqs_out - , case eqs_in of - CFunEqCan { cc_fun = tc, cc_tyargs = tys } : _ - -> insertTcApp noes (getUnique tc) tys eqs_in - _ -> noes ) - where - (eqs_out, eqs_in) = partition f cts + k ct (yeses, noes) + | f ct = (yeses `snocBag` ct, noes) + | otherwise = (yeses, insertFunEqCt noes ct) \end{code} @@ -987,21 +978,14 @@ data TcSEnv = TcSEnv { tcs_ev_binds :: EvBindsVar, - tcs_ty_binds :: IORef (Bool, TyVarEnv (TcTyVar, TcType)), - -- Global type bindings for unification variables - -- See Note [Spontaneously solved in TyBinds] in TcInteract - -- The "dirty-flag" Bool is set True when we add a binding + tcs_unified :: IORef Bool, + -- The "dirty-flag" Bool is set True when + -- we unify a unification variable tcs_count :: IORef Int, -- Global step count tcs_inerts :: IORef InertSet, -- Current inert set - tcs_worklist :: IORef WorkList, -- Current worklist - - -- Residual implication constraints that are generated - -- while solving or canonicalising the current worklist. - -- Specifically, when canonicalising (forall a. t1 ~ forall a. t2) - -- from which we get the implication (forall a. t1 ~ t2) - tcs_implics :: IORef (Bag Implication) + tcs_worklist :: IORef WorkList -- Current worklist } \end{code} @@ -1061,17 +1045,29 @@ bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env ; n <- TcM.readTcRef ref ; TcM.writeTcRef ref (n+1) } -traceFireTcS :: Ct -> SDoc -> TcS () +csTraceTcS :: SDoc -> TcS () +csTraceTcS doc + = wrapTcS $ csTraceTcM 1 (return doc) + +traceFireTcS :: CtEvidence -> SDoc -> TcS () -- Dump a rule-firing trace -traceFireTcS ct doc - = TcS $ \env -> - do { dflags <- getDynFlags - ; when (dopt Opt_D_dump_cs_trace dflags && traceLevel dflags >= 1) $ +traceFireTcS ev doc + = TcS $ \env -> csTraceTcM 1 $ do { n <- TcM.readTcRef (tcs_count env) - ; let msg = int n <> brackets (ppr (ctLocDepth (ctev_loc ev))) - <+> ppr ev <> colon <+> doc - ; TcM.debugDumpTcRn msg } } - where ev = cc_ev ct + ; untch <- TcM.getUntouchables + ; return (hang (int n <> brackets (ptext (sLit "U:") <> ppr untch + <> ppr (ctLocDepth (ctEvLoc ev))) + <+> doc <> colon) + 4 (ppr ev)) } + +csTraceTcM :: Int -> TcM SDoc -> TcM () +-- Constraint-solver tracing, -ddump-cs-trace +csTraceTcM trace_level mk_doc + = do { dflags <- getDynFlags + ; when ((dopt Opt_D_dump_cs_trace dflags || dopt Opt_D_dump_tc_trace dflags) + && traceLevel dflags >= trace_level) $ + do { msg <- mk_doc + ; TcM.debugDumpTcRn msg } } runTcS :: TcS a -- What to run -> TcM (a, Bag EvBind) @@ -1085,28 +1081,23 @@ runTcSWithEvBinds :: EvBindsVar -> TcS a -> TcM a runTcSWithEvBinds ev_binds_var tcs - = do { ty_binds_var <- TcM.newTcRef (False, emptyVarEnv) + = do { unified_var <- TcM.newTcRef False ; step_count <- TcM.newTcRef 0 ; inert_var <- TcM.newTcRef is + ; wl_var <- TcM.newTcRef emptyWorkList ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_ty_binds = ty_binds_var + , tcs_unified = unified_var , tcs_count = step_count , tcs_inerts = inert_var - , tcs_worklist = panic "runTcS: worklist" - , tcs_implics = panic "runTcS: implics" } - -- NB: Both these are initialised by withWorkList + , tcs_worklist = wl_var } -- Run the computation ; res <- unTcS tcs env - -- Perform the type unifications required - ; (_, ty_binds) <- TcM.readTcRef ty_binds_var - ; mapM_ do_unification (varEnvElts ty_binds) - ; TcM.whenDOptM Opt_D_dump_cs_trace $ - do { count <- TcM.readTcRef step_count - ; when (count > 0) $ - TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count ) } + ; count <- TcM.readTcRef step_count + ; when (count > 0) $ + csTraceTcM 0 $ return (ptext (sLit "Constraint solver steps =") <+> int count) #ifdef DEBUG ; ev_binds <- TcM.getTcEvBinds ev_binds_var @@ -1115,7 +1106,6 @@ runTcSWithEvBinds ev_binds_var tcs ; return res } where - do_unification (tv,ty) = TcM.writeMetaTyVar tv ty is = emptyInert #ifdef DEBUG @@ -1138,19 +1128,21 @@ checkForCyclicBinds ev_binds edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds] #endif -nestImplicTcS :: EvBindsVar -> Untouchables -> InertSet -> TcS a -> TcS a -nestImplicTcS ref inner_untch inerts (TcS thing_inside) - = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds +nestImplicTcS :: EvBindsVar -> Untouchables -> TcS a -> TcS a +nestImplicTcS ref inner_untch (TcS thing_inside) + = TcS $ \ TcSEnv { tcs_unified = unified_var + , tcs_inerts = old_inert_var , tcs_count = count } -> - do { new_inert_var <- TcM.newTcRef inerts + do { inerts <- TcM.readTcRef old_inert_var + ; let nest_inert = inerts { inert_flat_cache = emptyFunEqs } + -- See Note [Do not inherit the flat cache] + ; new_inert_var <- TcM.newTcRef nest_inert + ; new_wl_var <- TcM.newTcRef emptyWorkList ; let nest_env = TcSEnv { tcs_ev_binds = ref - , tcs_ty_binds = ty_binds + , tcs_unified = unified_var , tcs_count = count , tcs_inerts = new_inert_var - , tcs_worklist = panic "nestImplicTcS: worklist" - , tcs_implics = panic "nestImplicTcS: implics" - -- NB: Both these are initialised by withWorkList - } + , tcs_worklist = new_wl_var } ; res <- TcM.setUntouchables inner_untch $ thing_inside nest_env @@ -1169,34 +1161,31 @@ recoverTcS (TcS recovery_code) (TcS thing_inside) nestTcS :: TcS a -> TcS a -- Use the current untouchables, augmenting the current --- evidence bindings, ty_binds, and solved caches +-- evidence bindings, and solved caches -- But have no effect on the InertCans or insolubles nestTcS (TcS thing_inside) = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> do { inerts <- TcM.readTcRef inerts_var ; new_inert_var <- TcM.newTcRef inerts + ; new_wl_var <- TcM.newTcRef emptyWorkList ; let nest_env = env { tcs_inerts = new_inert_var - , tcs_worklist = panic "nestTcS: worklist" - , tcs_implics = panic "nestTcS: implics" } + , tcs_worklist = new_wl_var } ; thing_inside nest_env } tryTcS :: TcS a -> TcS a -- Like runTcS, but from within the TcS monad -- Completely fresh inerts and worklist, be careful! -- Moreover, we will simply throw away all the evidence generated. --- We have a completely empty tcs_ty_binds too, so make sure the --- input stuff is fully rewritten wrt any outer inerts tryTcS (TcS thing_inside) = TcS $ \env -> do { is_var <- TcM.newTcRef emptyInert - ; ty_binds_var <- TcM.newTcRef (False, emptyVarEnv) + ; unified_var <- TcM.newTcRef False ; ev_binds_var <- TcM.newTcEvBinds - + ; wl_var <- TcM.newTcRef emptyWorkList ; let nest_env = env { tcs_ev_binds = ev_binds_var - , tcs_ty_binds = ty_binds_var + , tcs_unified = unified_var , tcs_inerts = is_var - , tcs_worklist = panic "tryTcS: worklist" - , tcs_implics = panic "tryTcS: implics" } + , tcs_worklist = wl_var } ; thing_inside nest_env } -- Getters and setters of TcEnv fields @@ -1215,6 +1204,12 @@ getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) setTcSInerts :: InertSet -> TcS () setTcSInerts ics = do { r <- getTcSInertsRef; wrapTcS (TcM.writeTcRef r ics) } +getWorkListImplics :: TcS (Bag Implication) +getWorkListImplics + = do { wl_var <- getTcSWorkListRef + ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) + ; return (wl_implics wl_curr) } + updWorkListTcS :: (WorkList -> WorkList) -> TcS () updWorkListTcS f = do { wl_var <- getTcSWorkListRef @@ -1228,32 +1223,18 @@ updWorkListTcS_return :: (WorkList -> (a,WorkList)) -> TcS a updWorkListTcS_return f = do { wl_var <- getTcSWorkListRef ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) + ; traceTcS "updWorkList" (ppr wl_curr) ; let (res,new_work) = f wl_curr ; wrapTcS (TcM.writeTcRef wl_var new_work) ; return res } -withWorkList :: Cts -> TcS () -> TcS (Bag Implication) --- Use 'thing_inside' to solve 'work_items', extending the --- ambient InertSet, and returning any residual implications --- (arising from polytype equalities) --- We do this with fresh work list and residual-implications variables -withWorkList work_items (TcS thing_inside) - = TcS $ \ tcs_env -> - do { let init_work_list = foldrBag extendWorkListCt emptyWorkList work_items - ; new_wl_var <- TcM.newTcRef init_work_list - ; new_implics_var <- TcM.newTcRef emptyBag - ; thing_inside (tcs_env { tcs_worklist = new_wl_var - , tcs_implics = new_implics_var }) - ; final_wl <- TcM.readTcRef new_wl_var - ; implics <- TcM.readTcRef new_implics_var - ; ASSERT( isEmptyWorkList final_wl ) - return implics } - -updTcSImplics :: (Bag Implication -> Bag Implication) -> TcS () -updTcSImplics f - = do { impl_ref <- getTcSImplicsRef - ; wrapTcS $ do { implics <- TcM.readTcRef impl_ref - ; TcM.writeTcRef impl_ref (f implics) } } +emitWorkNC :: [CtEvidence] -> TcS () +emitWorkNC evs + | null evs + = return () + | otherwise + = do { traceTcS "Emitting fresh work" (vcat (map ppr evs)) + ; updWorkListTcS (extendWorkListCts (map mkNonCanonical evs)) } emitInsoluble :: Ct -> TcS () -- Emits a non-canonical constraint that will stand for a frozen error in the inerts. @@ -1264,58 +1245,19 @@ emitInsoluble ct this_pred = ctPred ct add_insol is@(IS { inert_cans = ics@(IC { inert_insols = old_insols }) }) | already_there = is - | otherwise = is { inert_cans = ics { inert_insols = extendCts old_insols ct } } + | otherwise = is { inert_cans = ics { inert_insols = old_insols `snocCts` ct } } where already_there = not (isWantedCt ct) && anyBag (tcEqType this_pred . ctPred) old_insols -- See Note [Do not add duplicate derived insolubles] -getTcSImplicsRef :: TcS (IORef (Bag Implication)) -getTcSImplicsRef = TcS (return . tcs_implics) - getTcEvBinds :: TcS EvBindsVar getTcEvBinds = TcS (return . tcs_ev_binds) getUntouchables :: TcS Untouchables getUntouchables = wrapTcS TcM.getUntouchables - -getGivenInfo :: TcS a -> TcS (Bool, [TcTyVar], a) --- See Note [inert_fsks and inert_no_eqs] -getGivenInfo thing_inside - = do { updInertTcS reset_vars -- Set inert_fsks and inert_no_eqs to initial values - ; res <- thing_inside -- Run thing_inside - ; is <- getTcSInerts -- Get new values of inert_fsks and inert_no_eqs - ; return (inert_no_eqs (inert_cans is), inert_fsks is, res) } - where - reset_vars :: InertSet -> InertSet - reset_vars is = is { inert_cans = (inert_cans is) { inert_no_eqs = True } - , inert_fsks = [] } \end{code} -Note [inert_fsks and inert_no_eqs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The function getGivenInfo runs thing_inside to see what new flatten-skolems -and equalities are generated by thing_inside. To that end, - * it initialises inert_fsks, inert_no_eqs - * runs thing_inside - * reads out inert_fsks, inert_no_eqs -This is the only place where it matters what inert_fsks and inert_no_eqs -are initialised to. In other places (eg emptyIntert), we need to set them -to something (because they are strict) but they will never be looked at. - -See Note [When does an implication have given equalities?] in TcSimplify -for more details about inert_no_eqs. - -See Note [Given flatten-skolems] for more details about inert_fsks. - \begin{code} -getTcSTyBinds :: TcS (IORef (Bool, TyVarEnv (TcTyVar, TcType))) -getTcSTyBinds = TcS (return . tcs_ty_binds) - -getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType)) -getTcSTyBindsMap = do { ref <- getTcSTyBinds - ; wrapTcS $ do { (_, binds) <- TcM.readTcRef ref - ; return binds } } - getTcEvBindsMap :: TcS EvBindMap getTcEvBindsMap = do { EvBindsVar ev_ref _ <- getTcEvBinds @@ -1325,33 +1267,26 @@ setWantedTyBind :: TcTyVar -> TcType -> TcS () -- Add a type binding -- We never do this twice! setWantedTyBind tv ty + | ASSERT2( isMetaTyVar tv, ppr tv ) + isFmvTyVar tv = ASSERT2( isMetaTyVar tv, ppr tv ) - do { ref <- getTcSTyBinds - ; wrapTcS $ - do { (_dirty, ty_binds) <- TcM.readTcRef ref - ; when debugIsOn $ - TcM.checkErr (not (tv `elemVarEnv` ty_binds)) $ - vcat [ text "TERRIBLE ERROR: double set of meta type variable" - , ppr tv <+> text ":=" <+> ppr ty - , text "Old value =" <+> ppr (lookupVarEnv_NF ty_binds tv)] - ; TcM.traceTc "setWantedTyBind" (ppr tv <+> text ":=" <+> ppr ty) - ; TcM.writeTcRef ref (True, extendVarEnv ty_binds tv (tv,ty)) } } + wrapTcS (TcM.writeMetaTyVar tv ty) + -- Write directly into the mutable tyvar + -- Flatten meta-vars are born and die locally + + | otherwise + = TcS $ \ env -> + do { TcM.traceTc "setWantedTyBind" (ppr tv <+> text ":=" <+> ppr ty) + ; TcM.writeMetaTyVar tv ty + ; TcM.writeTcRef (tcs_unified env) True } reportUnifications :: TcS a -> TcS (Bool, a) -reportUnifications thing_inside - = do { ty_binds_var <- getTcSTyBinds - ; outer_dirty <- wrapTcS $ - do { (outer_dirty, binds1) <- TcM.readTcRef ty_binds_var - ; TcM.writeTcRef ty_binds_var (False, binds1) - ; return outer_dirty } - ; res <- thing_inside - ; wrapTcS $ - do { (inner_dirty, binds2) <- TcM.readTcRef ty_binds_var - ; if inner_dirty then - return (True, res) - else - do { TcM.writeTcRef ty_binds_var (outer_dirty, binds2) - ; return (False, res) } } } +reportUnifications (TcS thing_inside) + = TcS $ \ env -> + do { inner_unified <- TcM.newTcRef False + ; res <- thing_inside (env { tcs_unified = inner_unified }) + ; dirty <- TcM.readTcRef inner_unified + ; return (dirty, res) } \end{code} \begin{code} @@ -1410,8 +1345,20 @@ isFilledMetaTyVar_maybe tv Flexi -> return Nothing } _ -> return Nothing +isFilledMetaTyVar :: TcTyVar -> TcS Bool +isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv) + zonkTyVarsAndFV :: TcTyVarSet -> TcS TcTyVarSet zonkTyVarsAndFV tvs = wrapTcS (TcM.zonkTyVarsAndFV tvs) + +zonkTcType :: TcType -> TcS TcType +zonkTcType ty = wrapTcS (TcM.zonkTcType ty) + +zonkTcTyVar :: TcTyVar -> TcS TcType +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] @@ -1468,41 +1415,39 @@ which will result in two Deriveds to end up in the insoluble set: \begin{code} -- Flatten skolems -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -newFlattenSkolem :: CtEvidence - -> TcType -- F xis - -> TcS (CtEvidence, TcType) -- co :: F xis ~ ty --- We have already looked up in the cache; no need to so so again -newFlattenSkolem ev fam_ty - | isGiven ev - = do { tv <- wrapTcS $ - do { uniq <- TcM.newUnique - ; let name = TcM.mkTcTyVarName uniq (fsLit "f") - ; return $ mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty) } - ; traceTcS "New Flatten Skolem Born" $ - ppr tv <+> text "[:= " <+> ppr fam_ty <+> text "]" - - ; updInertTcS $ \ is -> is { inert_fsks = tv : inert_fsks is } - - ; let rhs_ty = mkTyVarTy tv - ctev = CtGiven { ctev_pred = mkTcEqPred fam_ty rhs_ty - , ctev_evtm = EvCoercion (mkTcNomReflCo fam_ty) - , ctev_loc = (ctev_loc ev) { ctl_origin = FlatSkolOrigin } } - ; return (ctev, rhs_ty) } - - | otherwise -- Wanted or Derived: make new unification variable - = do { rhs_ty <- newFlexiTcSTy (typeKind fam_ty) - ; ctev <- newWantedEvVarNC (ctev_loc ev) (mkTcEqPred fam_ty rhs_ty) - -- NC (no-cache) version because we've already - -- looked in the solved goals and inerts (lookupFlatEqn) - ; return (ctev, rhs_ty) } - - -extendFlatCache :: TyCon -> [Type] -> CtEvidence -> TcType -> TcS () -extendFlatCache tc xi_args ev rhs_xi +newFlattenSkolem :: CtEvidence -> TcType -- F xis + -> TcS (CtEvidence, TcTyVar) -- [W] x:: F xis ~ fsk +newFlattenSkolem ctxt_ev fam_ty + | isGiven ctxt_ev -- Make a given + = do { fsk <- wrapTcS $ + do { uniq <- TcM.newUnique + ; let name = TcM.mkTcTyVarName uniq (fsLit "fsk") + ; return (mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty)) } + ; let ev = CtGiven { ctev_pred = mkTcEqPred fam_ty (mkTyVarTy fsk) + , ctev_evtm = EvCoercion (mkTcNomReflCo fam_ty) + , ctev_loc = loc } + ; return (ev, fsk) } + + | otherwise -- Make a wanted + = do { fuv <- wrapTcS $ + do { uniq <- TcM.newUnique + ; ref <- TcM.newMutVar Flexi + ; let details = MetaTv { mtv_info = FlatMetaTv + , mtv_ref = ref + , mtv_untch = fskUntouchables } + name = TcM.mkTcTyVarName uniq (fsLit "s") + ; return (mkTcTyVar name (typeKind fam_ty) details) } + ; ev <- newWantedEvVarNC loc (mkTcEqPred fam_ty (mkTyVarTy fuv)) + ; return (ev, fuv) } + where + loc = ctEvLoc ctxt_ev + +extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcTyVar) -> TcS () +extendFlatCache tc xi_args (co, fsk) = do { dflags <- getDynFlags ; when (gopt Opt_FlatCache dflags) $ updInertTcS $ \ is@(IS { inert_flat_cache = fc }) -> - is { inert_flat_cache = insertFunEq fc tc xi_args (ev, rhs_xi) } } + is { inert_flat_cache = insertFunEq fc tc xi_args (co, fsk) } } -- Instantiations -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1532,6 +1477,15 @@ newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) cloneMetaTyVar :: TcTyVar -> TcS TcTyVar cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) +demoteUnfilledFmv :: TcTyVar -> TcS () +-- If a flatten-meta-var is still un-filled, +-- turn it into an ordinary meta-var +demoteUnfilledFmv fmv + = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv + ; unless is_filled $ + do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv) + ; TcM.writeMetaTyVar fmv tv_ty } } + instFlexiTcS :: [TKVar] -> TcS (TvSubst, [TcType]) instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs) where @@ -1562,88 +1516,96 @@ data XEvTerm -- and each EvTerm has type of the corresponding EvPred } -data MaybeNew = Fresh CtEvidence | Cached EvTerm - -isFresh :: MaybeNew -> Bool -isFresh (Fresh {}) = True -isFresh _ = False - -getEvTerm :: MaybeNew -> EvTerm -getEvTerm (Fresh ctev) = ctEvTerm ctev -getEvTerm (Cached tm) = tm +data Freshness = Fresh | Cached -getEvTerms :: [MaybeNew] -> [EvTerm] -getEvTerms = map getEvTerm - -freshGoal :: MaybeNew -> Maybe CtEvidence -freshGoal (Fresh ctev) = Just ctev -freshGoal _ = Nothing - -freshGoals :: [MaybeNew] -> [CtEvidence] -freshGoals mns = [ ctev | Fresh ctev <- mns ] +freshGoals :: [(CtEvidence, Freshness)] -> [CtEvidence] +freshGoals mns = [ ctev | (ctev, Fresh) <- mns ] setEvBind :: EvVar -> EvTerm -> TcS () setEvBind the_ev tm - = do { traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr the_ev - , text "tm =" <+> ppr tm ] - ; tc_evbinds <- getTcEvBinds + = do { tc_evbinds <- getTcEvBinds ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm } +newTcEvBinds :: TcS EvBindsVar +newTcEvBinds = wrapTcS TcM.newTcEvBinds + +newEvVar :: TcPredType -> TcS EvVar +newEvVar pred = wrapTcS (TcM.newEvVar pred) + newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence -- Make a new variable of the given PredType, -- immediately bind it to the given term -- and return its CtEvidence newGivenEvVar loc (pred, rhs) - = do { new_ev <- wrapTcS $ TcM.newEvVar pred + = do { new_ev <- newEvVar pred ; setEvBind new_ev rhs ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev, ctev_loc = loc }) } newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence -- Don't look up in the solved/inerts; we know it's not there newWantedEvVarNC loc pty - = do { new_ev <- wrapTcS $ TcM.newEvVar pty + = do { new_ev <- newEvVar pty ; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc })} -- | Variant of newWantedEvVar that has a lower bound on the depth of the result -- (see Note [Preventing recursive dictionaries]) -newWantedEvVarNonrec :: CtLoc -> TcPredType -> TcS MaybeNew +newWantedEvVarNonrec :: CtLoc -> TcPredType -> TcS (CtEvidence, Freshness) newWantedEvVarNonrec loc pty = do { mb_ct <- lookupInInerts pty ; case mb_ct of Just ctev | not (isDerived ctev) && ctEvCheckDepth (ctLocDepth loc) ctev -> do { traceTcS "newWantedEvVarNonrec/cache hit" $ ppr ctev - ; return (Cached (ctEvTerm ctev)) } + ; return (ctev, Cached) } _ -> do { ctev <- newWantedEvVarNC loc pty ; traceTcS "newWantedEvVarNonrec/cache miss" $ ppr ctev - ; return (Fresh ctev) } } + ; return (ctev, Fresh) } } -newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew +newWantedEvVar :: CtLoc -> TcPredType -> TcS (CtEvidence, Freshness) newWantedEvVar loc pty = do { mb_ct <- lookupInInerts pty ; case mb_ct of Just ctev | not (isDerived ctev) -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev - ; return (Cached (ctEvTerm ctev)) } + ; return (ctev, Cached) } _ -> do { ctev <- newWantedEvVarNC loc pty ; traceTcS "newWantedEvVar/cache miss" $ ppr ctev - ; return (Fresh ctev) } } + ; return (ctev, Fresh) } } + +emitNewDerivedEq :: CtLoc -> Pair TcType -> TcS () +-- Create new Derived and put it in the work list +emitNewDerivedEq loc (Pair ty1 ty2) + | ty1 `tcEqType` ty2 -- Quite common! + = return () + | otherwise + = emitNewDerived loc (mkTcEqPred ty1 ty2) + +emitNewDerived :: CtLoc -> TcPredType -> TcS () +-- Create new Derived and put it in the work list +emitNewDerived loc pred + = do { mb_ct <- lookupInInerts pred + ; case mb_ct of + Just {} -> return () + Nothing -> do { traceTcS "Emitting [D]" (ppr der_ct) + ; updWorkListTcS (extendWorkListCt der_ct) } } + where + der_ct = mkNonCanonical (CtDerived { ctev_pred = pred, ctev_loc = loc }) newDerived :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) -- Returns Nothing if cached, -- Just pred if not cached -newDerived loc pty - = do { mb_ct <- lookupInInerts pty +newDerived loc pred + = do { mb_ct <- lookupInInerts pred ; return (case mb_ct of Just {} -> Nothing - Nothing -> Just (CtDerived { ctev_pred = pty, ctev_loc = loc })) } + Nothing -> Just (CtDerived { ctev_pred = pred, ctev_loc = loc })) } -instDFunConstraints :: CtLoc -> TcThetaType -> TcS [MaybeNew] +instDFunConstraints :: CtLoc -> TcThetaType -> TcS [(CtEvidence, Freshness)] instDFunConstraints loc = mapM (newWantedEvVar loc) \end{code} -Note [xCFlavor] -~~~~~~~~~~~~~~~ +Note [xCtEvidence] +~~~~~~~~~~~~~~~~~~ A call might look like this: xCtEvidence ev evidence-transformer @@ -1717,13 +1679,21 @@ TcCanonical), and will do no harm. \begin{code} xCtEvidence :: CtEvidence -- Original evidence -> XEvTerm -- Instructions about how to manipulate evidence - -> TcS [CtEvidence] + -> TcS () + +xCtEvidence (CtWanted { ctev_evar = evar, ctev_loc = loc }) + (XEvTerm { ev_preds = ptys, ev_comp = comp_fn }) + = do { new_evars <- mapM (newWantedEvVar loc) ptys + ; setEvBind evar (comp_fn (map (ctEvTerm . fst) new_evars)) + ; emitWorkNC (freshGoals new_evars) } + -- Note the "NC": these are fresh goals, not necessarily canonical xCtEvidence (CtGiven { ctev_evtm = tm, ctev_loc = loc }) (XEvTerm { ev_preds = ptys, ev_decomp = decomp_fn }) = ASSERT( equalLength ptys (decomp_fn tm) ) - mapM (newGivenEvVar loc) -- See Note [Bind new Givens immediately] - (filterOut bad_given_pred (ptys `zip` decomp_fn tm)) + do { given_evs <- mapM (newGivenEvVar loc) $ -- See Note [Bind new Givens immediately] + filterOut bad_given_pred (ptys `zip` decomp_fn tm) + ; emitWorkNC given_evs } where -- See Note [Do not create Given kind equalities] bad_given_pred (pred_ty, _) @@ -1732,22 +1702,46 @@ xCtEvidence (CtGiven { ctev_evtm = tm, ctev_loc = loc }) | otherwise = False -xCtEvidence (CtWanted { ctev_evar = evar, ctev_loc = loc }) - (XEvTerm { ev_preds = ptys, ev_comp = comp_fn }) - = do { new_evars <- mapM (newWantedEvVar loc) ptys - ; setEvBind evar (comp_fn (getEvTerms new_evars)) - ; return (freshGoals new_evars) } - xCtEvidence (CtDerived { ctev_loc = loc }) (XEvTerm { ev_preds = ptys }) - = do { ders <- mapM (newDerived loc) ptys - ; return (catMaybes ders) } + = mapM_ (emitNewDerived loc) ptys ----------------------------- +data StopOrContinue a + = ContinueWith a -- The constraint was not solved, although it may have + -- been rewritten + + | Stop CtEvidence -- The (rewritten) constraint was solved + SDoc -- Tells how it was solved + -- Any new sub-goals have been put on the work list + +instance Functor StopOrContinue where + fmap f (ContinueWith x) = ContinueWith (f x) + fmap _ (Stop ev s) = Stop ev s + +instance Outputable a => Outputable (StopOrContinue a) where + ppr (Stop ev s) = ptext (sLit "Stop") <> parens s <+> ppr ev + ppr (ContinueWith w) = ptext (sLit "ContinueWith") <+> ppr w + +continueWith :: a -> TcS (StopOrContinue a) +continueWith = return . ContinueWith + +stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) +stopWith ev s = return (Stop ev (text s)) + +andWhenContinue :: TcS (StopOrContinue a) + -> (a -> TcS (StopOrContinue b)) + -> TcS (StopOrContinue b) +andWhenContinue tcs1 tcs2 + = do { r <- tcs1 + ; case r of + Stop ev s -> return (Stop ev s) + ContinueWith ct -> tcs2 ct } + rewriteEvidence :: CtEvidence -- old evidence -> TcPredType -- new predicate -> TcCoercion -- Of type :: new predicate ~ <type of old evidence> - -> TcS (Maybe CtEvidence) + -> TcS (StopOrContinue CtEvidence) -- Returns Just new_ev iff either (i) 'co' is reflexivity -- or (ii) 'co' is not reflexivity, and 'new_pred' not cached -- In either case, there is nothing new to do with new_ev @@ -1782,7 +1776,7 @@ as well as in old_pred; that is important for good error messages. -} -rewriteEvidence (CtDerived { ctev_loc = loc }) new_pred _co +rewriteEvidence old_ev@(CtDerived { ctev_loc = loc }) new_pred _co = -- If derived, don't even look at the coercion. -- This is very important, DO NOT re-order the equations for -- rewriteEvidence to put the isTcReflCo test first! @@ -1790,23 +1784,28 @@ rewriteEvidence (CtDerived { ctev_loc = loc }) new_pred _co -- was produced by flattening, may contain suspended calls to -- (ctEvTerm c), which fails for Derived constraints. -- (Getting this wrong caused Trac #7384.) - newDerived loc new_pred + do { mb_ev <- newDerived loc new_pred + ; case mb_ev of + Just new_ev -> continueWith new_ev + Nothing -> stopWith old_ev "Cached derived" } rewriteEvidence old_ev new_pred co | isTcReflCo co -- See Note [Rewriting with Refl] - = return (Just (old_ev { ctev_pred = new_pred })) + = return (ContinueWith (old_ev { ctev_pred = new_pred })) rewriteEvidence (CtGiven { ctev_evtm = old_tm , ctev_loc = loc }) new_pred co = do { new_ev <- newGivenEvVar loc (new_pred, new_tm) -- See Note [Bind new Givens immediately] - ; return (Just new_ev) } + ; return (ContinueWith new_ev) } where new_tm = mkEvCast old_tm (mkTcSubCo (mkTcSymCo co)) -- mkEvCast optimises ReflCo -rewriteEvidence (CtWanted { ctev_evar = evar, ctev_loc = loc }) new_pred co - = do { new_evar <- newWantedEvVar loc new_pred +rewriteEvidence ev@(CtWanted { ctev_evar = evar, ctev_loc = loc }) new_pred co + = do { (new_ev, freshness) <- newWantedEvVar loc new_pred ; MASSERT( tcCoercionRole co == Nominal ) - ; setEvBind evar (mkEvCast (getEvTerm new_evar) (mkTcSubCo co)) - ; return (freshGoal new_evar) } + ; setEvBind evar (mkEvCast (ctEvTerm new_ev) (mkTcSubCo co)) + ; case freshness of + Fresh -> continueWith new_ev + Cached -> stopWith ev "Cached wanted" } rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) @@ -1816,7 +1815,7 @@ rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swap -- Should be zonked, because we use typeKind on nlhs/nrhs -> TcCoercion -- lhs_co, of type :: nlhs ~ olhs -> TcCoercion -- rhs_co, of type :: nrhs ~ orhs - -> TcS (Maybe CtEvidence) -- Of type nlhs ~ nrhs + -> TcS (StopOrContinue CtEvidence) -- Of type nlhs ~ nrhs -- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co) -- we generate -- If not swapped @@ -1834,29 +1833,33 @@ rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swap -- It's all a form of rewwriteEvidence, specialised for equalities rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co | CtDerived { ctev_loc = loc } <- old_ev - = newDerived loc (mkTcEqPred nlhs nrhs) + = do { mb <- newDerived loc (mkTcEqPred nlhs nrhs) + ; case mb of + Just new_ev -> continueWith new_ev + Nothing -> stopWith old_ev "Cached derived" } | NotSwapped <- swapped , isTcReflCo lhs_co -- See Note [Rewriting with Refl] , isTcReflCo rhs_co - = return (Just (old_ev { ctev_pred = new_pred })) + = 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 `mkTcTransCo` maybeSym swapped (evTermCoercion old_tm) `mkTcTransCo` mkTcSymCo rhs_co) ; new_ev <- newGivenEvVar loc (new_pred, new_tm) -- See Note [Bind new Givens immediately] - ; return (Just new_ev) } + ; return (ContinueWith new_ev) } | CtWanted { ctev_evar = evar, ctev_loc = loc } <- old_ev - = do { new_evar <- newWantedEvVar loc new_pred + = do { new_evar <- newWantedEvVarNC loc new_pred + -- Not much point in seeking exact-match equality evidence ; let co = maybeSym swapped $ mkTcSymCo lhs_co - `mkTcTransCo` evTermCoercion (getEvTerm new_evar) + `mkTcTransCo` ctEvCoercion new_evar `mkTcTransCo` rhs_co ; setEvBind evar (EvCoercion co) ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) - ; return (freshGoal new_evar) } + ; return (ContinueWith new_evar) } | otherwise = panic "rewriteEvidence" @@ -1900,6 +1903,17 @@ matchFam tycon args \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) +from which we get the implication + (forall a. t1 ~ t2) +See TcSMonad.deferTcSForAllEq + + \begin{code} -- Deferring forall equalities as implications -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1917,35 +1931,34 @@ deferTcSForAllEq role loc (tvs1,body1) (tvs2,body2) phi1 = Type.substTy subst1 body1 phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2 skol_info = UnifyForAllSkol skol_tvs phi1 - ; mev <- newWantedEvVar loc $ case role of - Nominal -> mkTcEqPred phi1 phi2 - Representational -> mkCoerciblePred phi1 phi2 - Phantom -> panic "deferTcSForAllEq Phantom" - ; coe_inside <- case mev of - Cached ev_tm -> return (evTermCoercion ev_tm) - Fresh ctev -> do { ev_binds_var <- wrapTcS $ TcM.newTcEvBinds - ; env <- wrapTcS $ TcM.getLclEnv - ; let ev_binds = TcEvBinds ev_binds_var - new_ct = mkNonCanonical ctev - new_co = evTermCoercion (ctEvTerm ctev) - new_untch = pushUntouchables (tcl_untch env) - ; let wc = WC { wc_flat = singleCt new_ct - , wc_impl = emptyBag - , wc_insol = emptyCts } - imp = Implic { ic_untch = new_untch - , ic_skols = skol_tvs - , ic_fsks = [] - , ic_no_eqs = True - , ic_given = [] - , ic_wanted = wc - , ic_insol = False - , ic_binds = ev_binds_var - , ic_env = env - , ic_info = skol_info } - ; updTcSImplics (consBag imp) - ; return (TcLetCo ev_binds new_co) } - - ; return $ EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs) - } + eq_pred = case role of + Nominal -> mkTcEqPred phi1 phi2 + Representational -> mkCoerciblePred phi1 phi2 + Phantom -> panic "deferTcSForAllEq Phantom" + ; (ctev, freshness) <- newWantedEvVar loc eq_pred + ; coe_inside <- case freshness of + Cached -> return (ctEvCoercion ctev) + Fresh -> do { ev_binds_var <- newTcEvBinds + ; env <- wrapTcS $ TcM.getLclEnv + ; let ev_binds = TcEvBinds ev_binds_var + new_ct = mkNonCanonical ctev + new_co = ctEvCoercion ctev + new_untch = pushUntouchables (tcl_untch env) + ; let wc = WC { wc_flat = singleCt new_ct + , wc_impl = emptyBag + , wc_insol = emptyCts } + imp = Implic { ic_untch = new_untch + , ic_skols = skol_tvs + , ic_no_eqs = True + , ic_given = [] + , ic_wanted = wc + , ic_insol = False + , ic_binds = ev_binds_var + , ic_env = env + , ic_info = skol_info } + ; updWorkListTcS (extendWorkListImplic imp) + ; 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.lhs index d8347635be..b13fdedc14 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -2,7 +2,8 @@ {-# LANGUAGE CPP #-} module TcSimplify( - simplifyInfer, quantifyPred, + simplifyInfer, + quantifyPred, growThetaTyVars, simplifyAmbiguityCheck, simplifyDefault, simplifyRule, simplifyTop, simplifyInteractive, @@ -18,15 +19,15 @@ import TcMType as TcM import TcType import TcSMonad as TcS import TcInteract -import Kind ( isKind, defaultKind_maybe ) +import Kind ( isKind, isSubKind, defaultKind_maybe ) import Inst -import FunDeps ( growThetaTyVars ) -import Type ( classifyPredType, PredTree(..), getClassPredTys_maybe ) +import Type ( classifyPredType, isIPClass, PredTree(..), getClassPredTys_maybe ) +import TyCon ( isSynFamilyTyCon ) import Class ( Class ) +import Id ( idType ) import Var import Unique import VarSet -import VarEnv import TcEvidence import Name import Bag @@ -41,6 +42,7 @@ import BasicTypes ( RuleName ) import Outputable import FastString import TrieMap () -- DV: for now +import Data.List( partition ) \end{code} @@ -58,7 +60,7 @@ simplifyTop :: WantedConstraints -> TcM (Bag EvBind) -- in a degenerate implication, so we do that here instead simplifyTop wanteds = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds - ; ev_binds_var <- newTcEvBinds + ; ev_binds_var <- TcM.newTcEvBinds ; zonked_final_wc <- solveWantedsTcMWithEvBinds ev_binds_var wanteds simpl_top ; binds1 <- TcRnMonad.getTcEvBinds ev_binds_var ; traceTc "End simplifyTop }" empty @@ -72,7 +74,7 @@ simplifyTop wanteds simpl_top :: WantedConstraints -> TcS WantedConstraints -- See Note [Top-level Defaulting Plan] simpl_top wanteds - = do { wc_first_go <- nestTcS (solve_wanteds_and_drop wanteds) + = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds) -- This is where the main work happens ; try_tyvar_defaulting wc_first_go } where @@ -91,7 +93,7 @@ simpl_top wanteds ; if meta_tvs' == meta_tvs -- No defaulting took place; -- (defaulting returns fresh vars) then try_class_defaulting wc - else do { wc_residual <- nestTcS (solve_wanteds_and_drop wc) + else do { wc_residual <- nestTcS (solveWantedsAndDrop wc) -- See Note [Must simplify after defaulting] ; try_class_defaulting wc_residual } } @@ -103,7 +105,7 @@ simpl_top wanteds = do { something_happened <- applyDefaultingRules (approximateWC wc) -- See Note [Top-level Defaulting Plan] ; if something_happened - then do { wc_residual <- nestTcS (solve_wanteds_and_drop wc) + then do { wc_residual <- nestTcS (solveWantedsAndDrop wc) ; try_class_defaulting wc_residual } else return wc } \end{code} @@ -189,7 +191,7 @@ More details in Note [DefaultTyVar]. simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () simplifyAmbiguityCheck ty wanteds = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) - ; ev_binds_var <- newTcEvBinds + ; ev_binds_var <- TcM.newTcEvBinds ; zonked_final_wc <- solveWantedsTcMWithEvBinds ev_binds_var wanteds simpl_top ; traceTc "End simplifyAmbiguityCheck }" empty @@ -236,8 +238,27 @@ simplifyDefault theta * * *********************************************************************************** +Note [Inferring the type of a let-bound variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = rhs + +To infer f's type we do the following: + * Gather the constraints for the RHS with ambient level *one more than* + the current one. This is done by the call + captureConstraints (captureUntouchables (tcMonoBinds...)) + in TcBinds.tcPolyInfer + + * Call simplifyInfer to simplify the constraints and decide what to + quantify over. We pass in the level used for the RHS constraints, + here called rhs_untch. + +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 :: Bool +simplifyInfer :: Untouchables -- Used when generating the constraints -> Bool -- Apply monomorphism restriction -> [(Name, TcTauType)] -- Variables to be generalised, -- and their tau-types @@ -248,7 +269,7 @@ simplifyInfer :: Bool -- so the results type is not as general as -- it could be TcEvBinds) -- ... binding these evidence variables -simplifyInfer _top_lvl apply_mr name_taus wanteds +simplifyInfer rhs_untch apply_mr name_taus wanteds | isEmptyWC wanteds = do { gbl_tvs <- tcGetGlobalTyVars ; qtkvs <- quantifyTyVars gbl_tvs (tyVarsOfTypes (map snd name_taus)) @@ -258,7 +279,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds | otherwise = do { traceTc "simplifyInfer {" $ vcat [ ptext (sLit "binds =") <+> ppr name_taus - , ptext (sLit "closed =") <+> ppr _top_lvl + , ptext (sLit "rhs_untch =") <+> ppr rhs_untch , ptext (sLit "apply_mr =") <+> ppr apply_mr , ptext (sLit "(unzonked) wanted =") <+> ppr wanteds ] @@ -278,10 +299,10 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- bindings, so we can't just revert to the input -- constraint. - ; ev_binds_var <- newTcEvBinds - ; wanted_transformed_incl_derivs - <- solveWantedsTcMWithEvBinds ev_binds_var wanteds solve_wanteds - -- Post: wanted_transformed_incl_derivs are zonked + ; ev_binds_var <- TcM.newTcEvBinds + ; wanted_transformed_incl_derivs <- setUntouchables rhs_untch $ + runTcSWithEvBinds ev_binds_var (solveWanteds wanteds) + ; wanted_transformed_incl_derivs <- zonkWC wanted_transformed_incl_derivs -- Step 4) Candidates for quantification are an approximation of wanted_transformed -- NB: Already the fixpoint of any unifications that may have happened @@ -289,83 +310,48 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- to less polymorphic types, see Note [Default while Inferring] ; tc_lcl_env <- TcRnMonad.getLclEnv - ; let untch = tcl_untch tc_lcl_env - wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs + ; null_ev_binds_var <- TcM.newTcEvBinds + ; let wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs ; quant_pred_candidates -- Fully zonked <- if insolubleWC wanted_transformed_incl_derivs then return [] -- See Note [Quantification with errors] - -- NB: must include derived errors in this test, + -- NB: must include derived errors in this test, -- hence "incl_derivs" else do { let quant_cand = approximateWC wanted_transformed meta_tvs = filter isMetaTyVar (varSetElems (tyVarsOfCts quant_cand)) ; gbl_tvs <- tcGetGlobalTyVars - ; null_ev_binds_var <- newTcEvBinds -- Miminise quant_cand. We are not interested in any evidence -- produced, because we are going to simplify wanted_transformed -- again later. All we want here is the predicates over which to - -- quantify. + -- quantify. -- -- If any meta-tyvar unifications take place (unlikely), we'll -- pick that up later. - ; (flats, _insols) <- runTcSWithEvBinds null_ev_binds_var $ - do { mapM_ (promoteAndDefaultTyVar untch gbl_tvs) meta_tvs - -- See Note [Promote _and_ default when inferring] - ; _implics <- solveInteract quant_cand - ; getInertUnsolved } - ; flats' <- zonkFlats null_ev_binds_var untch $ - filterBag isWantedCt flats - -- The quant_cand were already fully zonked, so this zonkFlats - -- really only unflattens the flattening that solveInteract - -- may have done (Trac #8889). - -- E.g. quant_cand = F a, where F :: * -> Constraint - -- We'll flatten to (alpha, F a ~ alpha) - -- fail to make any further progress and must unflatten again + ; WC { wc_flat = flats } + <- setUntouchables rhs_untch $ + runTcSWithEvBinds null_ev_binds_var $ + do { mapM_ (promoteAndDefaultTyVar rhs_untch gbl_tvs) meta_tvs + -- See Note [Promote _and_ default when inferring] + ; solveFlatWanteds quant_cand } - ; return (map ctPred $ bagToList flats') } + ; return [ ctEvPred ev | ct <- bagToList flats + , let ev = ctEvidence ct + , isWanted ev ] } -- NB: quant_pred_candidates is already the fixpoint of any -- unifications that may have happened - ; gbl_tvs <- tcGetGlobalTyVars - ; zonked_tau_tvs <- TcM.zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus)) - ; let poly_qtvs = growThetaTyVars quant_pred_candidates zonked_tau_tvs - `minusVarSet` gbl_tvs - pbound = filter (quantifyPred poly_qtvs) quant_pred_candidates - -- Monomorphism restriction - constrained_tvs = tyVarsOfTypes pbound `unionVarSet` gbl_tvs - mr_bites = apply_mr && not (null pbound) + ; zonked_tau_tvs <- TcM.zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus)) + ; (mono_tvs, qtvs, bound, mr_bites) <- decideQuantification apply_mr quant_pred_candidates zonked_tau_tvs - ; (qtvs, bound) <- if mr_bites - then do { qtvs <- quantifyTyVars constrained_tvs zonked_tau_tvs - ; return (qtvs, []) } - else do { qtvs <- quantifyTyVars gbl_tvs poly_qtvs - ; return (qtvs, pbound) } + ; outer_untch <- TcRnMonad.getUntouchables + ; runTcSWithEvBinds null_ev_binds_var $ -- runTcS just to get the types right :-( + mapM_ (promoteTyVar outer_untch) (varSetElems (zonked_tau_tvs `intersectVarSet` mono_tvs)) - ; traceTc "simplifyWithApprox" $ - vcat [ ptext (sLit "quant_pred_candidates =") <+> ppr quant_pred_candidates - , ptext (sLit "gbl_tvs=") <+> ppr gbl_tvs - , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs - , ptext (sLit "pbound =") <+> ppr pbound - , ptext (sLit "bbound =") <+> ppr bound - , ptext (sLit "poly_qtvs =") <+> ppr poly_qtvs - , ptext (sLit "constrained_tvs =") <+> ppr constrained_tvs - , ptext (sLit "mr_bites =") <+> ppr mr_bites - , ptext (sLit "qtvs =") <+> ppr qtvs ] - - ; if null qtvs && null bound - then do { traceTc "} simplifyInfer/no implication needed" empty - ; emitConstraints wanted_transformed - -- Includes insolubles (if -fdefer-type-errors) - -- as well as flats and implications - ; return ([], [], mr_bites, TcEvBinds ev_binds_var) } - else do - - { -- Step 7) Emit an implication - -- See Trac #9633 for an instructive example - let minimal_flat_preds = mkMinimalBySCs bound + ; let minimal_flat_preds = mkMinimalBySCs bound -- See Note [Minimize by Superclasses] skol_info = InferSkol [ (name, mkSigmaTy [] minimal_flat_preds ty) | (name, ty) <- name_taus ] @@ -374,11 +360,9 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- tidied uniformly ; minimal_bound_ev_vars <- mapM TcM.newEvVar minimal_flat_preds - ; let implic = Implic { ic_untch = pushUntouchables untch + ; let implic = Implic { ic_untch = rhs_untch , ic_skols = qtvs , ic_no_eqs = False - , ic_fsks = [] -- wanted_tansformed arose only from solveWanteds - -- hence no flatten-skolems (which come from givens) , ic_given = minimal_bound_ev_vars , ic_wanted = wanted_transformed , ic_insol = False @@ -388,22 +372,125 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds ; emitImplication implic ; traceTc "} simplifyInfer/produced residual implication for quantification" $ - vcat [ ptext (sLit "implic =") <+> ppr implic - -- ic_skols, ic_given give rest of result - , ptext (sLit "qtvs =") <+> ppr qtvs - , ptext (sLit "spb =") <+> ppr quant_pred_candidates - , ptext (sLit "bound =") <+> ppr bound ] + vcat [ ptext (sLit "quant_pred_candidates =") <+> ppr quant_pred_candidates + , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs + , ptext (sLit "mono_tvs=") <+> ppr mono_tvs + , ptext (sLit "bound =") <+> ppr bound + , 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the monomorphism restriction does not apply, then we quantify as follows: + * Take the global tyvars, and "grow" them using the equality constraints + E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can + happen because alpha is untouchable here) then do not quantify over + beta + These are the mono_tvs + * Take the free vars of the tau-type (zonked_tau_tvs) and "grow" them + using all the constraints, but knocking out the mono_tvs + + The result is poly_qtvs, which we will quantify over. + + * Filter the constraints using quantifyPred and the poly_qtvs + +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 -- Do not quantify over these + , [TcTyVar] -- Do quantify over these + , [PredType] -- and these + , Bool ) -- Did the MR bite? +-- See Note [Deciding quantification] +decideQuantification apply_mr constraints zonked_tau_tvs + | apply_mr -- Apply the Monomorphism restriction + = do { gbl_tvs <- tcGetGlobalTyVars + ; let constrained_tvs = tyVarsOfTypes constraints + mono_tvs = gbl_tvs `unionVarSet` constrained_tvs + mr_bites = constrained_tvs `intersectsVarSet` zonked_tau_tvs + ; qtvs <- quantifyTyVars mono_tvs zonked_tau_tvs + ; return (mono_tvs, qtvs, [], mr_bites) } + + | otherwise + = do { gbl_tvs <- tcGetGlobalTyVars + ; let mono_tvs = growThetaTyVars (filter isEqPred constraints) gbl_tvs + poly_qtvs = growThetaTyVars constraints zonked_tau_tvs + `minusVarSet` mono_tvs + theta = filter (quantifyPred poly_qtvs) constraints + ; qtvs <- quantifyTyVars mono_tvs poly_qtvs + ; return (mono_tvs, qtvs, theta, False) } + +------------------ quantifyPred :: TyVarSet -- Quantifying over these -> PredType -> Bool -- True <=> quantify over this wanted quantifyPred qtvs pred - | isIPPred pred = True -- Note [Inheriting implicit parameters] - | otherwise = tyVarsOfType pred `intersectsVarSet` qtvs + = case classifyPredType pred of + ClassPred cls tys + | isIPClass cls -> True -- See note [Inheriting implicit parameters] + | otherwise -> tyVarsOfTypes tys `intersectsVarSet` qtvs + EqPred ty1 ty2 -> quant_fun ty1 || quant_fun ty2 + IrredPred ty -> tyVarsOfType ty `intersectsVarSet` qtvs + TuplePred {} -> False + where + -- Only quantify over (F tys ~ ty) if tys mentions a quantifed variable + -- In particular, quanitifying over (F Int ~ ty) is a bit like quantifying + -- over (Eq Int); the instance should kick in right here + quant_fun ty + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) | isSynFamilyTyCon tc + -> tyVarsOfTypes tys `intersectsVarSet` qtvs + _ -> False + +------------------ +growThetaTyVars :: ThetaType -> TyVarSet -> TyVarSet +-- See Note [Growing the tau-tvs using constraints] +growThetaTyVars theta tvs + | null theta = tvs + | isEmptyVarSet seed_tvs = tvs + | otherwise = fixVarSet mk_next seed_tvs + where + seed_tvs = tvs `unionVarSet` tyVarsOfTypes ips + (ips, non_ips) = partition isIPPred theta + -- See note [Inheriting implicit parameters] + mk_next tvs = foldr grow_one tvs non_ips + grow_one pred tvs + | pred_tvs `intersectsVarSet` tvs = tvs `unionVarSet` pred_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 + of tyvars tvs using all conceivable links from pred + +E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e} +Then growThetaTyVars preds tvs = {a,b,c} + +Notice that + growThetaTyVars is conservative if v might be fixed by vs + => v `elem` grow(vs,C) + Note [Inheriting implicit parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this: @@ -551,7 +638,7 @@ simplifyRule name lhs_wanted rhs_wanted (resid_wanted, _) <- solveWantedsTcM (lhs_wanted `andWC` rhs_wanted) -- Post: these are zonked and unflattened - ; zonked_lhs_flats <- zonkCts (wc_flat lhs_wanted) + ; zonked_lhs_flats <- TcM.zonkFlats (wc_flat lhs_wanted) ; let (q_cts, non_q_cts) = partitionBag quantify_me zonked_lhs_flats quantify_me -- Note [RULE quantification over equalities] | insolubleWC resid_wanted = quantify_insol @@ -643,7 +730,7 @@ solveWantedsTcMWithEvBinds :: EvBindsVar solveWantedsTcMWithEvBinds ev_binds_var wc tcs_action = do { traceTc "solveWantedsTcMWithEvBinds" $ text "wanted=" <+> ppr wc ; wc2 <- runTcSWithEvBinds ev_binds_var (tcs_action wc) - ; zonkWC ev_binds_var wc2 } + ; zonkWC wc2 } -- See Note [Zonk after solving] solveWantedsTcM :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind) @@ -652,22 +739,22 @@ solveWantedsTcM :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind) -- Discards all Derived stuff in result -- Postcondition: fully zonked and unflattened constraints solveWantedsTcM wanted - = do { ev_binds_var <- newTcEvBinds - ; wanteds' <- solveWantedsTcMWithEvBinds ev_binds_var wanted solve_wanteds_and_drop + = do { ev_binds_var <- TcM.newTcEvBinds + ; wanteds' <- solveWantedsTcMWithEvBinds ev_binds_var wanted solveWantedsAndDrop ; binds <- TcRnMonad.getTcEvBinds ev_binds_var ; return (wanteds', binds) } -solve_wanteds_and_drop :: WantedConstraints -> TcS (WantedConstraints) --- Since solve_wanteds returns the residual WantedConstraints, +solveWantedsAndDrop :: WantedConstraints -> TcS (WantedConstraints) +-- Since solveWanteds returns the residual WantedConstraints, -- it should always be called within a runTcS or something similar, -solve_wanteds_and_drop wanted = do { wc <- solve_wanteds wanted - ; return (dropDerivedWC wc) } +solveWantedsAndDrop wanted = do { wc <- solveWanteds wanted + ; return (dropDerivedWC wc) } -solve_wanteds :: WantedConstraints -> TcS WantedConstraints +solveWanteds :: WantedConstraints -> TcS WantedConstraints -- so that the inert set doesn't mindlessly propagate. -- NB: wc_flats may be wanted /or/ derived now -solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols }) - = do { traceTcS "solveWanteds {" (ppr wanted) +solveWanteds wanteds + = do { traceTcS "solveWanteds {" (ppr wanteds) -- Try the flat bit, including insolubles. Solving insolubles a -- second time round is a bit of a waste; but the code is simple @@ -675,57 +762,63 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols -- of adding Derived insolubles twice; see -- TcSMonad Note [Do not add duplicate derived insolubles] ; traceTcS "solveFlats {" empty - ; let all_flats = flats `unionBags` filterBag (not . isDerivedCt) insols - -- See Note [Dropping derived constraints] in TcRnTypes for - -- why the insolubles may have derived constraints - - ; impls_from_flats <- solveInteract all_flats - ; traceTcS "solveFlats end }" (ppr impls_from_flats) - - -- solve_wanteds iterates when it is able to float equalities - -- out of one or more of the implications. - ; unsolved_implics <- simpl_loop 1 (implics `unionBags` impls_from_flats) - - ; (unsolved_flats, insoluble_flats) <- getInertUnsolved + ; solved_flats_wanteds <- solveFlats wanteds + ; traceTcS "solveFlats end }" (ppr solved_flats_wanteds) - -- We used to unflatten here but now we only do it once at top-level - -- during zonking -- see Note [Unflattening while zonking] in TcMType - ; let wc = WC { wc_flat = unsolved_flats - , wc_impl = unsolved_implics - , wc_insol = insoluble_flats } + -- solveWanteds iterates when it is able to float equalities + -- equalities out of one or more of the implications. + ; final_wanteds <- simpl_loop 1 solved_flats_wanteds ; bb <- getTcEvBindsMap - ; tb <- getTcSTyBindsMap ; traceTcS "solveWanteds }" $ - vcat [ text "unsolved_flats =" <+> ppr unsolved_flats - , text "unsolved_implics =" <+> ppr unsolved_implics - , text "current evbinds =" <+> ppr (evBindMapBinds bb) - , text "current tybinds =" <+> vcat (map ppr (varEnvElts tb)) - , text "final wc =" <+> ppr wc ] - - ; return wc } + vcat [ text "final wc =" <+> ppr final_wanteds + , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] + + ; return final_wanteds } + +solveFlats :: WantedConstraints -> TcS WantedConstraints +-- Solve the wc_flat and wc_insol components of the WantedConstraints +-- Do not affect the inerts +solveFlats (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) + = nestTcS $ + do { let all_flats = flats `unionBags` filterBag (not . isDerivedCt) insols + -- See Note [Dropping derived constraints] in TcRnTypes for + -- why the insolubles may have derived constraints + ; wc <- solveFlatWanteds all_flats + ; return ( wc { wc_impl = implics `unionBags` wc_impl wc } ) } simpl_loop :: Int - -> Bag Implication - -> TcS (Bag Implication) -simpl_loop n implics + -> WantedConstraints + -> TcS WantedConstraints +simpl_loop n wanteds@(WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) | n > 10 - = traceTcS "solveWanteds: loop!" empty >> return implics + = do { traceTcS "solveWanteds: loop!" empty + ; return wanteds } + | otherwise = do { traceTcS "simpl_loop, iteration" (int n) ; (floated_eqs, unsolved_implics) <- solveNestedImplications implics + ; if isEmptyBag floated_eqs - then return unsolved_implics + then return (wanteds { wc_impl = unsolved_implics }) else + do { -- Put floated_eqs into the current inert set before looping - (unifs_happened, impls_from_eqs) <- reportUnifications $ - solveInteract floated_eqs - ; if -- See Note [Cutting off simpl_loop] - isEmptyBag impls_from_eqs && - not unifs_happened && -- (a) - not (anyBag isCFunEqCan floated_eqs) -- (b) - then return unsolved_implics - else simpl_loop (n+1) (unsolved_implics `unionBags` impls_from_eqs) } } + (unifs_happened, solve_flat_res) + <- reportUnifications $ + solveFlats (WC { wc_flat = floated_eqs `unionBags` flats + -- Put floated_eqs first so they get solved first + , wc_insol = emptyBag, wc_impl = emptyBag }) + + ; let new_wanteds = solve_flat_res `andWC` + WC { wc_flat = emptyBag + , wc_insol = insols + , wc_impl = unsolved_implics } + + ; if not unifs_happened -- See Note [Cutting off simpl_loop] + && isEmptyBag (wc_impl solve_flat_res) + then return new_wanteds + else simpl_loop (n+1) new_wanteds } } solveNestedImplications :: Bag Implication -> TcS (Cts, Bag Implication) @@ -735,16 +828,17 @@ solveNestedImplications implics | isEmptyBag implics = return (emptyBag, emptyBag) | otherwise - = do { inerts <- getTcSInerts - ; let thinner_inerts = prepareInertsForImplications inerts - -- See Note [Preparing inert set for implications] - - ; traceTcS "solveNestedImplications starting {" $ - vcat [ text "original inerts = " <+> ppr inerts - , text "thinner_inerts = " <+> ppr thinner_inerts ] + = do { +-- inerts <- getTcSInerts +-- ; let thinner_inerts = prepareInertsForImplications inerts +-- -- See Note [Preparing inert set for implications] +-- + traceTcS "solveNestedImplications starting {" empty +-- vcat [ text "original inerts = " <+> ppr inerts +-- , text "thinner_inerts = " <+> ppr thinner_inerts ] ; (floated_eqs, unsolved_implics) - <- flatMapBagPairM (solveImplication thinner_inerts) implics + <- flatMapBagPairM solveImplication implics -- ... and we are back in the original TcS inerts -- Notice that the original includes the _insoluble_flats so it was safe to ignore @@ -755,45 +849,45 @@ solveNestedImplications implics ; return (floated_eqs, unsolved_implics) } -solveImplication :: InertSet - -> Implication -- Wanted +solveImplication :: Implication -- Wanted -> TcS (Cts, -- All wanted or derived floated equalities: var = type Bag Implication) -- Unsolved rest (always empty or singleton) -- Precondition: The TcS monad contains an empty worklist and given-only inerts -- which after trying to solve this implication we must restore to their original value -solveImplication inerts - imp@(Implic { ic_untch = untch - , ic_binds = ev_binds - , ic_skols = skols - , ic_fsks = old_fsks - , ic_given = givens - , ic_wanted = wanteds - , ic_info = info - , ic_env = env }) - = do { traceTcS "solveImplication {" (ppr imp) +solveImplication imp@(Implic { ic_untch = untch + , ic_binds = ev_binds + , ic_skols = skols + , ic_given = givens + , ic_wanted = wanteds + , ic_info = info + , ic_env = env }) + = do { inerts <- getTcSInerts + ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) -- Solve the nested constraints - ; (no_given_eqs, new_fsks, residual_wanted) - <- nestImplicTcS ev_binds untch inerts $ - do { (no_eqs, new_fsks) <- solveInteractGiven (mkGivenLoc info env) - old_fsks givens + ; (no_given_eqs, residual_wanted) + <- nestImplicTcS ev_binds untch $ + do { solveFlatGivens (mkGivenLoc untch info env) givens - ; residual_wanted <- solve_wanteds wanteds - -- solve_wanteds, *not* solve_wanteds_and_drop, because + ; residual_wanted <- solveWanteds wanteds + -- solveWanteds, *not* solveWantedsAndDrop, because -- we want to retain derived equalities so we can float -- them out in floatEqualities - ; return (no_eqs, new_fsks, residual_wanted) } + ; no_eqs <- getNoGivenEqs untch skols + + ; return (no_eqs, residual_wanted) } ; (floated_eqs, final_wanted) - <- floatEqualities (skols ++ new_fsks) no_given_eqs residual_wanted + <- floatEqualities skols no_given_eqs residual_wanted - ; let res_implic | isEmptyWC final_wanted && no_given_eqs + ; let res_implic | isEmptyWC final_wanted -- && no_given_eqs = emptyBag -- Reason for the no_given_eqs: we don't want to -- lose the "inaccessible code" error message + -- BUT: final_wanted still has the derived insolubles + -- so it should be fine | otherwise - = unitBag (imp { ic_fsks = new_fsks - , ic_no_eqs = no_given_eqs + = unitBag (imp { ic_no_eqs = no_given_eqs , ic_wanted = dropDerivedWC final_wanted , ic_insol = insolubleWC final_wanted }) @@ -801,7 +895,6 @@ solveImplication inerts ; traceTcS "solveImplication end }" $ vcat [ text "no_given_eqs =" <+> ppr no_given_eqs , text "floated_eqs =" <+> ppr floated_eqs - , text "new_fsks =" <+> ppr new_fsks , text "res_implic =" <+> ppr res_implic , text "implication evbinds = " <+> ppr (evBindMapBinds evbinds) ] @@ -911,7 +1004,6 @@ approximateWC wc = emptyCts -- See Note [ApproximateWC] where new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp - `extendVarSetList` ic_fsks imp do_bag :: (a -> Bag c) -> Bag a -> Bag c do_bag f = foldrBag (unionBags.f) emptyBag \end{code} @@ -1042,7 +1134,6 @@ beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: data TEx where TEx :: a -> TEx - f (x::beta) = let g1 :: forall b. b -> () g1 _ = h [x] @@ -1050,7 +1141,6 @@ beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: in (g1 '3', g2 undefined) - Note [Solving Family Equations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ After we are done with simplification we may be left with constraints of the form: @@ -1126,112 +1216,74 @@ 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 +floatEqualities :: [TcTyVar] -> Bool + -> WantedConstraints -> TcS (Cts, WantedConstraints) -- Main idea: see Note [Float Equalities out of Implications] -- --- Post: The returned floated constraints (Cts) are only Wanted or Derived --- and come from the input wanted ev vars or deriveds +-- 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 +-- ev vars or deriveds +-- -- Also performs some unifications (via promoteTyVar), adding to -- monadically-carried ty_binds. These will be used when processing -- floated_eqs later -- -- Subtleties: Note [Float equalities from under a skolem binding] -- Note [Skolem escape] -floatEqualities skols no_given_eqs wanteds@(WC { wc_flat = flats, wc_insol = insols }) +floatEqualities skols no_given_eqs wanteds@(WC { wc_flat = flats }) | not no_given_eqs -- There are some given equalities, so don't float = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] - | not (isEmptyBag insols) - = return (emptyBag, wanteds) -- Note [Do not float equalities if there are insolubles] | otherwise - = do { let (float_eqs, remaining_flats) = partitionBag is_floatable flats - ; untch <- TcS.getUntouchables - ; mapM_ (promoteTyVar untch) (varSetElems (tyVarsOfCts float_eqs)) + = do { outer_untch <- TcS.getUntouchables + ; mapM_ (promoteTyVar outer_untch) (varSetElems (tyVarsOfCts float_eqs)) -- See Note [Promoting unification variables] - ; ty_binds <- getTcSTyBindsMap ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols , text "Flats =" <+> ppr flats - , text "Skol set =" <+> ppr skol_set - , text "Floated eqs =" <+> ppr float_eqs - , text "Ty binds =" <+> ppr ty_binds]) + , text "Floated eqs =" <+> ppr float_eqs ]) ; return (float_eqs, wanteds { wc_flat = remaining_flats }) } where - is_floatable :: Ct -> Bool - is_floatable ct - = case classifyPredType (ctPred ct) of - EqPred ty1 ty2 -> skol_set `disjointVarSet` tyVarsOfType ty1 - && skol_set `disjointVarSet` tyVarsOfType ty2 - _ -> False - - skol_set = fixVarSet mk_next (mkVarSet skols) - mk_next tvs = foldr grow_one tvs flat_eqs - flat_eqs :: [(TcTyVarSet, TcTyVarSet)] - flat_eqs = [ (tyVarsOfType ty1, tyVarsOfType ty2) - | EqPred ty1 ty2 <- map (classifyPredType . ctPred) (bagToList flats)] - grow_one (tvs1,tvs2) tvs - | intersectsVarSet tvs tvs1 = tvs `unionVarSet` tvs2 - | intersectsVarSet tvs tvs2 = tvs `unionVarSet` tvs2 - | otherwise = tvs + skol_set = mkVarSet skols + (float_eqs, remaining_flats) = partitionBag float_me flats + + float_me :: Ct -> Bool + float_me ct -- The constraint is un-flattened and de-cannonicalised + | let pred = ctPred ct + , EqPred ty1 ty2 <- classifyPredType pred + , tyVarsOfType pred `disjointVarSet` skol_set + , useful_to_float ty1 ty2 + = True + | otherwise + = False + + -- Float out alpha ~ ty, or ty ~ alpha + -- which might be unified outside + -- See Note [Do not float kind-incompatible equalities] + useful_to_float ty1 ty2 + = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of + (Just tv1, _) | isMetaTyVar tv1 + , k2 `isSubKind` k1 + -> True + (_, Just tv2) | isMetaTyVar tv2 + , k1 `isSubKind` k2 + -> True + _ -> False + where + k1 = typeKind ty1 + k2 = typeKind ty2 \end{code} -Note [Do not float equalities if there are insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Do not float kind-incompatible equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have (t::* ~ s::*->*), we'll get a Derived insoluble equality. If we float the equality outwards, we'll get *another* Derived insoluble equality one level out, so the same error will be reported -twice. However, the equality is insoluble anyway, and when there are -any insolubles we report only them, so there is no point in floating. - - -Note [When does an implication have given equalities?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - NB: This note is mainly referred to from TcSMonad - but it relates to floating equalities, so I've - left it here - -Consider an implication - beta => alpha ~ Int -where beta is a unification variable that has already been unified -to () in an outer scope. Then we can float the (alpha ~ Int) out -just fine. So when deciding whether the givens contain an equality, -we should canonicalise first, rather than just looking at the original -givens (Trac #8644). - -This is the entire reason for the inert_no_eqs field in InertCans. -We initialise it to False before processing the Givens of an implication; -and set it to True when adding an inert equality in addInertCan. - -However, when flattening givens, we generate given equalities like - <F [a]> : F [a] ~ f, -with Refl evidence, and we *don't* want those to count as an equality -in the givens! After all, the entire flattening business is just an -internal matter, and the evidence does not mention any of the 'givens' -of this implication. - -So we set the flag to False when adding an equality -(TcSMonad.addInertCan) whose evidence whose CtOrigin is -FlatSkolOrigin; see TcSMonad.isFlatSkolEv. Note that we may transform -the original flat-skol equality before adding it to the inerts, so -it's important that the transformation preserves origin (which -xCtEvidence and rewriteEvidence both do). Example - instance F [a] = Maybe a - implication: C (F [a]) => blah - We flatten (C (F [a])) to C fsk, with <F [a]> : F [a] ~ fsk - Then we reduce the F [a] LHS, giving - g22 = ax7 ; <F [a]> - g22 : Maybe a ~ fsk - And before adding g22 we'll re-orient it to an ordinary tyvar - equality. None of this should count as "adding a given equality". - This really happens (Trac #8651). - -An alternative we considered was to - * Accumulate the new inert equalities (in TcSMonad.addInertCan) - * In solveInteractGiven, check whether the evidence for the new - equalities mentions any of the ic_givens of this implication. -This seems like the Right Thing, but it's more code, and more work -at runtime, so we are using the FlatSkolOrigin idea intead. It's less -obvious that it works, but I think it does, and it's simple and efficient. +twice. So we refrain from floating such equalities Note [Float equalities from under a skolem binding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1240,72 +1292,21 @@ ones that don't mention the skolem-bound variables. But that is over-eager. Consider [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int The second constraint doesn't mention 'a'. But if we float it -we'll promote gamma to gamma'[1]. Now suppose that we learn that +we'll promote gamma[2] to gamma'[1]. Now suppose that we learn that beta := Bool, and F a Bool = a, and G Bool _ = Int. Then we'll we left with the constraint [2] forall a. a ~ gamma'[1] which is insoluble because gamma became untouchable. -Solution: only promote a constraint if its free variables cannot -possibly be connected with the skolems. Procedurally, start with -the skolems and "grow" that set as follows: - * For each flat equality F ts ~ s, or tv ~ s, - if the current set intersects with the LHS of the equality, - add the free vars of the RHS, and vice versa -That gives us a grown skolem set. Now float an equality if its free -vars don't intersect the grown skolem set. - -This seems very ad hoc (sigh). But here are some tricky edge cases: - -a) [2]forall a. (F a delta[1] ~ beta[2], delta[1] ~ Maybe beta[2]) -b1) [2]forall a. (F a ty ~ beta[2], G beta[2] ~ gamma[2]) -b2) [2]forall a. (a ~ beta[2], G beta[2] ~ gamma[2]) -c) [2]forall a. (F a ty ~ beta[2], delta[1] ~ Maybe beta[2]) -d) [2]forall a. (gamma[1] ~ Tree beta[2], F ty ~ beta[2]) - -In (a) we *must* float out the second equality, - else we can't solve at all (Trac #7804). - -In (b1, b2) we *must not* float out the second equality. - It will ultimately be solved (by flattening) in situ, but if we float - it we'll promote beta,gamma, and render the first equality insoluble. - - Trac #9316 was an example of (b2). You may wonder why (a ~ beta[2]) isn't - solved; in #9316 it wasn't solved because (a:*) and (beta:kappa[1]), so the - equality was kind-mismatched, and hence was a CIrredEvCan. There was - another equality alongside, (kappa[1] ~ *). We must first float *that* - one out and *then* we can solve (a ~ beta). - -In (c) it would be OK to float the second equality but better not to. - If we flatten we see (delta[1] ~ Maybe (F a ty)), which is a - skolem-escape problem. If we float the second equality we'll - end up with (F a ty ~ beta'[1]), which is a less explicable error. - -In (d) we must float the first equality, so that we can unify gamma. - But that promotes beta, so we must float the second equality too, - Trac #7196 exhibits this case - -Some notes - -* When "growing", do not simply take the free vars of the predicate! - Example [2]forall a. (a:* ~ beta[2]:kappa[1]), (kappa[1] ~ *) - We must float the second, and we must not float the first. - But the first actually looks like ((~) kappa a beta), so if we just - look at its free variables we'll see {a,kappa,beta), and that might - make us think kappa should be in the grown skol set. - - (In any case, the kind argument for a kind-mis-matched equality like - this one doesn't really make sense anyway.) - - That's why we use classifyPred when growing. - -* Previously we tried to "grow" the skol_set with *all* the - constraints (not just equalities), to get all the tyvars that could - *conceivably* unify with the skolems, but that was far too - conservative (Trac #7804). Example: this should be fine: - f :: (forall a. a -> Proxy x -> Proxy (F x)) -> Int - f = error "Urk" :: (forall a. a -> Proxy x -> Proxy (F x)) -> Int +Solution: float only constraints that stand a jolly good chance of +being soluble simply by being floated, namely ones of form + a ~ ty +where 'a' is a currently-untouchable unification variable, but may +become touchable by being floated (perhaps by more than one level). +We had a very complicated rule previously, but this is nice and +simple. (To see the notes, look at this Note in a version of +TcSimplify prior to Oct 2014). Note [Skolem escape] ~~~~~~~~~~~~~~~~~~~~ @@ -1423,15 +1424,13 @@ disambigGroup [] _grp = return False disambigGroup (default_ty:default_tys) group = do { traceTcS "disambigGroup {" (ppr group $$ ppr default_ty) - ; success <- tryTcS $ -- Why tryTcS? If this attempt fails, we want to - -- discard all side effects from the attempt - do { setWantedTyBind the_tv default_ty - ; implics_from_defaulting <- solveInteract wanteds - ; MASSERT(isEmptyBag implics_from_defaulting) - -- I am not certain if any implications can be generated - -- but I am letting this fail aggressively if this ever happens. - - ; checkAllSolved } + ; fake_ev_binds_var <- TcS.newTcEvBinds + ; given_ev_var <- TcS.newEvVar (mkTcEqPred (mkTyVarTy the_tv) default_ty) + ; untch <- TcS.getUntouchables + ; success <- nestImplicTcS fake_ev_binds_var (pushUntouchables untch) $ + do { solveFlatGivens loc [given_ev_var] + ; residual_wanted <- solveFlatWanteds wanteds + ; return (isEmptyWC residual_wanted) } ; if success then -- Success: record the type variable binding, and return @@ -1445,8 +1444,11 @@ disambigGroup (default_ty:default_tys) group (ppr default_ty) ; disambigGroup default_tys group } } where - ((_,_,the_tv):_) = group wanteds = listToBag (map fstOf3 group) + ((_,_,the_tv):_) = group + loc = CtLoc { ctl_origin = GivenOrigin UnkSkol + , ctl_env = panic "disambigGroup:env" + , ctl_depth = initialSubGoalDepth } \end{code} Note [Avoiding spurious errors] diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 77077d4d30..5d610b40da 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -28,8 +28,8 @@ import TcRnMonad import TcEnv import TcValidity import TcHsSyn +import TcSimplify( growThetaTyVars ) import TcBinds( tcRecSelBinds ) -import FunDeps( growThetaTyVars ) import TcTyDecls import TcClassDcl import TcHsType @@ -1369,25 +1369,9 @@ since GADTs are not kind indexed. Validity checking is done once the mutually-recursive knot has been tied, so we can look at things freely. -Note [Abort when superclass cycle is detected] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must avoid doing the ambiguity check when there are already errors accumulated. -This is because one of the errors may be a superclass cycle, and superclass cycles -cause canonicalization to loop. Here is a representative example: - - class D a => C a where - meth :: D a => () - class C a => D a - -This fixes Trac #9415. - \begin{code} checkClassCycleErrs :: Class -> TcM () -checkClassCycleErrs cls - = unless (null cls_cycles) $ - do { mapM_ recClsErr cls_cycles - ; failM } -- See Note [Abort when superclass cycle is detected] - where cls_cycles = calcClassCycles cls +checkClassCycleErrs cls = mapM_ recClsErr (calcClassCycles cls) checkValidTyCl :: TyThing -> TcM () checkValidTyCl thing @@ -1640,8 +1624,11 @@ checkValidClass cls -- If there are superclass cycles, checkClassCycleErrs bails. ; checkClassCycleErrs cls - -- Check the class operations - ; mapM_ (check_op constrained_class_methods) op_stuff + -- Check the class operations. + -- But only if there have been no earlier errors + -- See Note [Abort when superclass cycle is detected] + ; whenNoErrs $ + mapM_ (check_op constrained_class_methods) op_stuff -- Check the associated type defaults are well-formed and instantiated ; mapM_ check_at_defs at_stuff } @@ -1707,6 +1694,20 @@ checkFamFlag 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 +checkValidClass.check_op) when there are already errors accumulated. +This is because one of the errors may be a superclass cycle, and +superclass cycles cause canonicalization to loop. Here is a +representative example: + + class D a => C a where + meth :: D a => () + class C a => D a + +This fixes Trac #9415, #9739 + %************************************************************************ %* * Checking role validity diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index ffd3e070bb..a4a646c8e9 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -24,7 +24,8 @@ module TcType ( TcTyVar, TcTyVarSet, TcKind, TcCoVar, -- Untouchables - Untouchables(..), noUntouchables, pushUntouchables, isTouchable, + Untouchables(..), noUntouchables, pushUntouchables, + strictlyDeeperThan, sameDepthAs, fskUntouchables, -------------------------------- -- MetaDetails @@ -32,12 +33,14 @@ module TcType ( TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, MetaDetails(Flexi, Indirect), MetaInfo(..), isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, - isSigTyVar, isOverlappableTyVar, isTyConableTyVar, isFlatSkolTyVar, + isSigTyVar, isOverlappableTyVar, isTyConableTyVar, + isFskTyVar, isFmvTyVar, isFlattenTyVar, isAmbiguousTyVar, metaTvRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, isTypeVar, isKindVar, - metaTyVarUntouchables, setMetaTyVarUntouchables, - isTouchableMetaTyVar, isFloatedTouchableMetaTyVar, + metaTyVarUntouchables, setMetaTyVarUntouchables, metaTyVarUntouchables_maybe, + isTouchableMetaTyVar, isTouchableOrFmv, + isFloatedTouchableMetaTyVar, -------------------------------- -- Builders @@ -274,17 +277,13 @@ data TcTyVarDetails -- when looking up instances -- See Note [Binding when looking up instances] in InstEnv + | FlatSkol -- A flatten-skolem. It stands for the TcType, and zonking + TcType -- will replace it by that type. + -- See Note [The flattening story] in TcFlatten + | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi -- interactive context - | FlatSkol TcType - -- The "skolem" obtained by flattening during - -- constraint simplification - - -- In comments we will use the notation alpha[flat = ty] - -- to represent a flattening skolem variable alpha - -- identified with type ty. - | MetaTv { mtv_info :: MetaInfo , mtv_ref :: IORef MetaDetails , mtv_untch :: Untouchables } -- See Note [Untouchable type variables] @@ -317,6 +316,10 @@ data MetaInfo -- The MetaDetails, if filled in, will -- always be another SigTv or a SkolemTv + | FlatMetaTv -- A flatten meta-tyvar + -- It is a meta-tyvar, but it is always untouchable, with level 0 + -- See Note [The flattening story] in TcFlatten + ------------------------------------- -- UserTypeCtxt describes the origin of the polymorphic type -- in the places where we need to an expression has that type @@ -420,30 +423,34 @@ The same idea of only unifying touchables solves another problem. Suppose we had (F Int ~ uf[0]) /\ [1](forall a. C a => F Int ~ beta[1]) In this example, beta is touchable inside the implication. The -first solveInteract step leaves 'uf' un-unified. Then we move inside +first solveFlatWanteds step leaves 'uf' un-unified. Then we move inside the implication where a new constraint uf ~ beta 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 solveCTyFunEqs stage and +(F Int ~ uf) which will be unified by our final zonking stage and uf will get unified *once more* to (F Int). \begin{code} -newtype Untouchables = Untouchables Int +newtype Untouchables = Untouchables Int deriving( Eq ) -- See Note [Untouchable type variables] for what this Int is +fskUntouchables :: Untouchables +fskUntouchables = Untouchables 0 -- 0 = Outside the outermost level: + -- flatten skolems + noUntouchables :: Untouchables -noUntouchables = Untouchables 0 -- 0 = outermost level +noUntouchables = Untouchables 1 -- 1 = outermost level pushUntouchables :: Untouchables -> Untouchables pushUntouchables (Untouchables us) = Untouchables (us+1) -isFloatedTouchable :: Untouchables -> Untouchables -> Bool -isFloatedTouchable (Untouchables ctxt_untch) (Untouchables tv_untch) - = ctxt_untch < tv_untch +strictlyDeeperThan :: Untouchables -> Untouchables -> Bool +strictlyDeeperThan (Untouchables tv_untch) (Untouchables ctxt_untch) + = tv_untch > ctxt_untch -isTouchable :: Untouchables -> Untouchables -> Bool -isTouchable (Untouchables ctxt_untch) (Untouchables tv_untch) +sameDepthAs :: Untouchables -> Untouchables -> Bool +sameDepthAs (Untouchables ctxt_untch) (Untouchables tv_untch) = ctxt_untch == tv_untch -- NB: invariant ctxt_untch >= tv_untch -- So <= would be equivalent @@ -471,12 +478,13 @@ pprTcTyVarDetails (SkolemTv False) = ptext (sLit "sk") pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_untch = untch }) - = pp_info <> brackets (ppr untch) + = pp_info <> colon <> ppr untch where pp_info = case info of - PolyTv -> ptext (sLit "poly") - TauTv -> ptext (sLit "tau") - SigTv -> ptext (sLit "sig") + PolyTv -> ptext (sLit "poly") + TauTv -> ptext (sLit "tau") + SigTv -> ptext (sLit "sig") + FlatMetaTv -> ptext (sLit "fuv") pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n) @@ -583,6 +591,18 @@ exactTyVarsOfTypes = mapUnionVarSet exactTyVarsOfType %************************************************************************ \begin{code} +isTouchableOrFmv :: Untouchables -> TcTyVar -> Bool +isTouchableOrFmv ctxt_untch tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_untch = tv_untch, mtv_info = info } + -> ASSERT2( checkTouchableInvariant ctxt_untch tv_untch, + ppr tv $$ ppr tv_untch $$ ppr ctxt_untch ) + case info of + FlatMetaTv -> True + _ -> tv_untch `sameDepthAs` ctxt_untch + _ -> False + isTouchableMetaTyVar :: Untouchables -> TcTyVar -> Bool isTouchableMetaTyVar ctxt_untch tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -590,14 +610,14 @@ isTouchableMetaTyVar ctxt_untch tv MetaTv { mtv_untch = tv_untch } -> ASSERT2( checkTouchableInvariant ctxt_untch tv_untch, ppr tv $$ ppr tv_untch $$ ppr ctxt_untch ) - isTouchable ctxt_untch tv_untch + tv_untch `sameDepthAs` ctxt_untch _ -> False isFloatedTouchableMetaTyVar :: Untouchables -> TcTyVar -> Bool isFloatedTouchableMetaTyVar ctxt_untch tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of - MetaTv { mtv_untch = tv_untch } -> isFloatedTouchable ctxt_untch tv_untch + MetaTv { mtv_untch = tv_untch } -> tv_untch `strictlyDeeperThan` ctxt_untch _ -> False isImmutableTyVar :: TyVar -> Bool @@ -606,7 +626,8 @@ isImmutableTyVar tv | otherwise = True isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, - isMetaTyVar, isAmbiguousTyVar, isFlatSkolTyVar :: TcTyVar -> Bool + isMetaTyVar, isAmbiguousTyVar, + isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool isTyConableTyVar tv -- True of a meta-type variable that can be filled in @@ -617,7 +638,22 @@ isTyConableTyVar tv MetaTv { mtv_info = SigTv } -> False _ -> True -isFlatSkolTyVar tv +isFmvTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = FlatMetaTv } -> True + _ -> False + +-- | True of both given and wanted flatten-skolems (fak and usk) +isFlattenTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + FlatSkol {} -> True + MetaTv { mtv_info = FlatMetaTv } -> True + _ -> False + +-- | True of FlatSkol skolems only +isFskTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of FlatSkol {} -> True @@ -626,10 +662,8 @@ isFlatSkolTyVar tv isSkolemTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of - SkolemTv {} -> True - FlatSkol {} -> True - RuntimeUnk {} -> True - MetaTv {} -> False + MetaTv {} -> False + _other -> True isOverlappableTyVar tv = ASSERT( isTcTyVar tv ) @@ -673,6 +707,13 @@ metaTyVarUntouchables tv MetaTv { mtv_untch = untch } -> untch _ -> pprPanic "metaTyVarUntouchables" (ppr tv) +metaTyVarUntouchables_maybe :: TcTyVar -> Maybe Untouchables +metaTyVarUntouchables_maybe tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + MetaTv { mtv_untch = untch } -> Just untch + _ -> Nothing + setMetaTyVarUntouchables :: TcTyVar -> Untouchables -> TcTyVar setMetaTyVarUntouchables tv untch = ASSERT( isTcTyVar tv ) diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 389c4a3142..f5033ee08a 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -451,7 +451,6 @@ newImplication skol_info skol_tvs given thing_inside ; env <- getLclEnv ; emitImplication $ Implic { ic_untch = untch , ic_skols = skol_tvs - , ic_fsks = [] , ic_no_eqs = False , ic_given = given , ic_wanted = wanted diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 36eb711bdc..dc0a7d0d45 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -844,7 +844,7 @@ mkSubCo: Requires a nominal input coercion and always produces a representational output. This is used when you (the programmer) are sure you know exactly that role you have and what you want. -setRole_maybe: This function takes both the input role and the output role +downgradeRole_maybe: This function takes both the input role and the output role as parameters. (The *output* role comes first!) It can only *downgrade* a role -- that is, change it from N to R or P, or from R to P. This one-way behavior is why there is the "_maybe". If an upgrade is requested, this @@ -853,10 +853,10 @@ coercion, but you're not sure (as you're writing the code) of which roles are involved. This function could have been written using coercionRole to ascertain the role -of the input. But, that function is recursive, and the caller of setRole_maybe +of the input. But, that function is recursive, and the caller of downgradeRole_maybe often knows the input role. So, this is more efficient. -downgradeRole: This is just like setRole_maybe, but it panics if the conversion +downgradeRole: This is just like downgradeRole_maybe, but it panics if the conversion isn't a downgrade. setNominalRole_maybe: This is the only function that can *upgrade* a coercion. The result @@ -880,7 +880,7 @@ API, as he was decomposing Core casts. The Core casts use representational coerc as they must, but his use case required nominal coercions (he was building a GADT). So, that's why this function is exported from this module. -One might ask: shouldn't setRole_maybe just use setNominalRole_maybe as appropriate? +One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as appropriate? I (Richard E.) have decided not to do this, because upgrading a role is bizarre and a caller should have to ask for this behavior explicitly. @@ -1081,15 +1081,15 @@ mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole c SubCo co -- only *downgrades* a role. See Note [Role twiddling functions] -setRole_maybe :: Role -- desired role - -> Role -- current role - -> Coercion -> Maybe Coercion -setRole_maybe Representational Nominal = Just . mkSubCo -setRole_maybe Nominal Representational = const Nothing -setRole_maybe Phantom Phantom = Just -setRole_maybe Phantom _ = Just . mkPhantomCo -setRole_maybe _ Phantom = const Nothing -setRole_maybe _ _ = Just +downgradeRole_maybe :: Role -- desired role + -> Role -- current role + -> Coercion -> Maybe Coercion +downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) +downgradeRole_maybe Nominal Representational _ = Nothing +downgradeRole_maybe Phantom Phantom co = Just co +downgradeRole_maybe Phantom _ co = Just (mkPhantomCo co) +downgradeRole_maybe _ Phantom _ = Nothing +downgradeRole_maybe _ _ co = Just co -- panics if the requested conversion is not a downgrade. -- See also Note [Role twiddling functions] @@ -1097,7 +1097,7 @@ downgradeRole :: Role -- desired role -> Role -- current role -> Coercion -> Coercion downgradeRole r1 r2 co - = case setRole_maybe r1 r2 co of + = case downgradeRole_maybe r1 r2 co of Just co' -> co' Nothing -> pprPanic "downgradeRole" (ppr co) @@ -1158,8 +1158,9 @@ nthRole Phantom _ _ = Phantom nthRole Representational tc n = (tyConRolesX Representational tc) !! n --- is one role "less" than another? ltRole :: Role -> Role -> Bool +-- Is one role "less" than another? +-- Nominal < Representational < Phantom ltRole Phantom _ = False ltRole Representational Phantom = True ltRole Representational _ = False @@ -1619,17 +1620,16 @@ failing for reason 2) is fine. matchAxiom is trying to find a set of coercions that match, but it may fail, and this is healthy behavior. Bottom line: if you find that liftCoSubst is doing weird things (like leaving out-of-scope variables lying around), disable coercion optimization (bypassing matchAxiom) -and use downgradeRole instead of setRole_maybe. The panic will then happen, +and use downgradeRole instead of downgradeRole_maybe. The panic will then happen, and you may learn something useful. \begin{code} - liftCoSubstTyVar :: LiftCoSubst -> Role -> TyVar -> Maybe Coercion liftCoSubstTyVar (LCS _ cenv) r tv = do { co <- lookupVarEnv cenv tv ; let co_role = coercionRole co -- could theoretically take this as -- a parameter, but painful - ; setRole_maybe r co_role co } -- see Note [liftCoSubstTyVar] + ; downgradeRole_maybe r co_role co } -- see Note [liftCoSubstTyVar] liftCoSubstTyVarBndr :: LiftCoSubst -> TyVar -> (LiftCoSubst, TyVar) liftCoSubstTyVarBndr subst@(LCS in_scope cenv) old_var diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 7fe35ffcda..bc21e2e1d7 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -361,7 +361,8 @@ extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv -extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm}) +extendFamInstEnv inst_env + ins_item@(FamInst {fi_fam = cls_nm}) = addToUFM_C add inst_env cls_nm (FamIE [ins_item]) where add (FamIE items) _ = FamIE (ins_item:items) @@ -789,18 +790,33 @@ The lookupFamInstEnv function does a nice job for *open* type families, but we also need to handle closed ones when normalising a type: \begin{code} -reduceTyFamApp_maybe :: FamInstEnvs -> Role -> TyCon -> [Type] -> Maybe (Coercion, Type) +reduceTyFamApp_maybe :: FamInstEnvs + -> Role -- Desired role of result coercion + -> TyCon -> [Type] + -> Maybe (Coercion, Type) -- Attempt to do a *one-step* reduction of a type-family application +-- but *not* newtypes +-- Works on type-synonym families always; data-families only if +-- the role we seek is representational -- It first normalises the type arguments, wrt functions but *not* newtypes, --- to be sure that nested calls like --- F (G Int) --- are correctly reduced +-- to be sure that nested calls like +-- F (G Int) +-- are correctly reduced -- -- The TyCon can be oversaturated. -- Works on both open and closed families reduceTyFamApp_maybe envs role tc tys - | isOpenFamilyTyCon tc + | Phantom <- role + = Nothing + + | case role of + Representational -> isOpenFamilyTyCon tc + _ -> isOpenSynFamilyTyCon tc + -- If we seek a representational coercion + -- (e.g. the call in topNormaliseType_maybe) then we can + -- unwrap data families as well as type-synonym families; + -- otherwise only type-synonym families , [FamInstMatch { fim_instance = fam_inst , fim_tys = inst_tys }] <- lookupFamInstEnv envs tc ntys = let ax = famInstAxiom fam_inst @@ -927,12 +943,18 @@ topNormaliseType_maybe env ty --------------- normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) +-- See comments on normaliseType for the arguments of this function normaliseTcApp env role tc tys + | isTypeSynonymTyCon tc + , (co1, ntys) <- normaliseTcArgs env role tc tys + , Just (tenv, rhs, ntys') <- tcExpandTyCon_maybe tc ntys + , (co2, ninst_rhs) <- normaliseType env role (Type.substTy (mkTopTvSubst tenv) rhs) + = if isReflCo co2 then (co1, mkTyConApp tc ntys) + else (co1 `mkTransCo` co2, mkAppTys ninst_rhs ntys') + | Just (first_co, ty') <- reduceTyFamApp_maybe env role tc tys - = let -- A reduction is possible - (rest_co,nty) = normaliseType env role ty' - in - (first_co `mkTransCo` rest_co, nty) + , (rest_co,nty) <- normaliseType env role ty' + = (first_co `mkTransCo` rest_co, nty) | otherwise -- No unique matching family instance exists; -- we do not do anything @@ -958,10 +980,10 @@ normaliseType :: FamInstEnvs -- environment with family instances -> (Coercion, Type) -- (coercion,new type), where -- co :: old-type ~ new_type -- Normalise the input type, by eliminating *all* type-function redexes +-- but *not* newtypes (which are visible to the programmer) -- Returns with Refl if nothing happens +-- Try to not to disturb type syonyms if possible -normaliseType env role ty - | Just ty' <- coreView ty = normaliseType env role ty' normaliseType env role (TyConApp tc tys) = normaliseTcApp env role tc tys normaliseType _env role ty@(LitTy {}) = (Refl role ty, ty) diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 1e7e02335f..6d03fbe094 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -161,8 +161,8 @@ pprInstance :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstance ispec = hang (pprInstanceHdr ispec) - 2 (vcat [ ptext (sLit "--") <+> pprDefinedAt (getName ispec) - , ifPprDebug (ppr (is_dfun ispec)) ]) + 2 (vcat [ ptext (sLit "--") <+> pprDefinedAt (getName ispec) + , ifPprDebug (ppr (is_dfun ispec)) ]) -- * pprInstanceHdr is used in VStudio to populate the ClassView tree pprInstanceHdr :: ClsInst -> SDoc diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 953797e499..a4ba48c609 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -41,7 +41,7 @@ module Outputable ( -- * Converting 'SDoc' into strings and outputing it printForC, printForAsm, printForUser, printForUserPartWay, pprCode, mkCodeStyle, - showSDoc, showSDocOneLine, + showSDoc, showSDocSimple, showSDocOneLine, showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, showSDocUnqual, showPpr, renderWithStyle, @@ -64,7 +64,7 @@ module Outputable ( pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, ifPprDebug, qualName, qualModule, qualPackage, - mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, + mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, mkUserStyle, cmdlineParserStyle, Depth(..), -- * Error handling and debugging utilities @@ -125,15 +125,16 @@ data PprStyle -- Assumes printing tidied code: non-system names are -- printed without uniques. - | PprCode CodeStyle - -- Print code; either C or assembler - - | PprDump -- For -ddump-foo; less verbose than PprDebug. + | PprDump PrintUnqualified + -- For -ddump-foo; less verbose than PprDebug, but more than PprUser -- Does not assume tidied code: non-external names -- are printed with uniques. | PprDebug -- Full debugging output + | PprCode CodeStyle + -- Print code; either C or assembler + data CodeStyle = CStyle -- The format of labels differs for C and assembler | AsmStyle @@ -221,7 +222,11 @@ defaultUserStyle = mkUserStyle neverQualify AllTheWay -- Print without qualifiers to reduce verbosity, unless -dppr-debug defaultDumpStyle | opt_PprStyle_Debug = PprDebug - | otherwise = PprDump + | otherwise = PprDump neverQualify + +mkDumpStyle :: PrintUnqualified -> PprStyle +mkDumpStyle print_unqual | opt_PprStyle_Debug = PprDebug + | otherwise = PprDump print_unqual defaultErrStyle :: DynFlags -> PprStyle -- Default style for error messages, when we don't know PrintUnqualified @@ -324,15 +329,18 @@ sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) \begin{code} qualName :: PprStyle -> QueryQualifyName qualName (PprUser q _) mod occ = queryQualifyName q mod occ +qualName (PprDump q) mod occ = queryQualifyName q mod occ qualName _other mod _ = NameQual (moduleName mod) qualModule :: PprStyle -> QueryQualifyModule qualModule (PprUser q _) m = queryQualifyModule q m -qualModule _other _m = True +qualModule (PprDump q) m = queryQualifyModule q m +qualModule _other _m = True qualPackage :: PprStyle -> QueryQualifyPackage qualPackage (PprUser q _) m = queryQualifyPackage q m -qualPackage _other _m = True +qualPackage (PprDump q) m = queryQualifyPackage q m +qualPackage _other _m = True queryQual :: PprStyle -> PrintUnqualified queryQual s = QueryQualify (qualName s) @@ -348,8 +356,8 @@ asmStyle (PprCode AsmStyle) = True asmStyle _other = False dumpStyle :: PprStyle -> Bool -dumpStyle PprDump = True -dumpStyle _other = False +dumpStyle (PprDump {}) = True +dumpStyle _other = False debugStyle :: PprStyle -> Bool debugStyle PprDebug = True @@ -402,6 +410,27 @@ mkCodeStyle = PprCode showSDoc :: DynFlags -> SDoc -> String showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle +showSDocSimple :: SDoc -> String +showSDocSimple sdoc = showSDoc unsafeGlobalDynFlags sdoc + +showPpr :: Outputable a => DynFlags -> a -> String +showPpr dflags thing = showSDoc dflags (ppr thing) + +showSDocUnqual :: DynFlags -> SDoc -> String +-- Only used by Haddock +showSDocUnqual dflags sdoc = showSDoc dflags sdoc + +showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String +-- Allows caller to specify the PrintUnqualified to use +showSDocForUser dflags unqual doc + = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay) + +showSDocDump :: DynFlags -> SDoc -> String +showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle + +showSDocDebug :: DynFlags -> SDoc -> String +showSDocDebug dflags d = renderWithStyle dflags d PprDebug + renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String renderWithStyle dflags sdoc sty = Pretty.showDoc PageMode (pprCols dflags) $ @@ -415,28 +444,10 @@ showSDocOneLine dflags d = Pretty.showDoc OneLineMode (pprCols dflags) $ runSDoc d (initSDocContext dflags defaultUserStyle) -showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String -showSDocForUser dflags unqual doc - = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay) - -showSDocUnqual :: DynFlags -> SDoc -> String --- Only used by Haddock -showSDocUnqual dflags doc - = renderWithStyle dflags doc (mkUserStyle neverQualify AllTheWay) - -showSDocDump :: DynFlags -> SDoc -> String -showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle - -showSDocDebug :: DynFlags -> SDoc -> String -showSDocDebug dflags d = renderWithStyle dflags d PprDebug - showSDocDumpOneLine :: DynFlags -> SDoc -> String showSDocDumpOneLine dflags d = Pretty.showDoc OneLineMode irrelevantNCols $ - runSDoc d (initSDocContext dflags PprDump) - -showPpr :: Outputable a => DynFlags -> a -> String -showPpr dflags thing = showSDoc dflags (ppr thing) + runSDoc d (initSDocContext dflags defaultDumpStyle) irrelevantNCols :: Int -- Used for OneLineMode and LeftMode when number of cols isn't used @@ -1000,7 +1011,7 @@ pprTrace :: String -> SDoc -> a -> a -- ^ If debug output is on, show some 'SDoc' on the screen pprTrace str doc x | opt_NoDebugOutput = x - | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace str doc x + | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x pprPanicFastInt :: String -> SDoc -> FastInt -- ^ Specialization of pprPanic that can be safely used with 'FastInt' @@ -1013,9 +1024,9 @@ warnPprTrace _ _ _ _ x | not debugIsOn = x warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = pprDebugAndThen unsafeGlobalDynFlags trace str msg x + = pprDebugAndThen unsafeGlobalDynFlags trace heading msg x where - str = showSDoc unsafeGlobalDynFlags (hsep [text "WARNING: file", text file <> comma, text "line", int line]) + heading = hsep [text "WARNING: file", text file <> comma, text "line", int line] assertPprPanic :: String -> Int -> SDoc -> a -- ^ Panic with an assertation failure, recording the given file and line number. @@ -1027,10 +1038,10 @@ assertPprPanic file line msg , text "line", int line ] , msg ] -pprDebugAndThen :: DynFlags -> (String -> a) -> String -> SDoc -> a +pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a pprDebugAndThen dflags cont heading pretty_msg = cont (showSDocDump dflags doc) where - doc = sep [text heading, nest 4 pretty_msg] + doc = sep [heading, nest 2 pretty_msg] \end{code} diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs index 8b8c8e80b7..0ea8efaf5b 100644 --- a/libraries/base/Data/Monoid.hs +++ b/libraries/base/Data/Monoid.hs @@ -3,6 +3,7 @@ {-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} ----------------------------------------------------------------------------- diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs index 8835df45e8..e8bfbfff16 100644 --- a/libraries/base/GHC/Generics.hs +++ b/libraries/base/GHC/Generics.hs @@ -1,10 +1,17 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric #-} @@ -548,12 +555,13 @@ module GHC.Generics ( , (:+:)(..), (:*:)(..), (:.:)(..) -- ** Synonyms for convenience - , Rec0, Par0, R, P + , Rec0, R , D1, C1, S1, D, C, S -- * Meta-information , Datatype(..), Constructor(..), Selector(..), NoSelector - , Fixity(..), Associativity(..), Arity(..), prec + , Fixity(..), Associativity(..), prec -- Arity(..), + , Meta(..) -- * Generic type classes , Generic(..), Generic1(..) @@ -561,6 +569,7 @@ module GHC.Generics ( ) where -- We use some base types +import GHC.Integer ( Integer, integerToInt ) import GHC.Types import Data.Maybe ( Maybe(..) ) import Data.Either ( Either(..) ) @@ -569,17 +578,20 @@ import Data.Either ( Either(..) ) import GHC.Classes ( Eq, Ord ) import GHC.Read ( Read ) import GHC.Show ( Show ) -import Data.Proxy + +-- Needed for metadata +import Data.Proxy ( Proxy(..), KProxy(..) ) +import GHC.TypeLits ( Nat, Symbol, KnownSymbol, KnownNat, symbolVal, natVal ) -------------------------------------------------------------------------------- -- Representation types -------------------------------------------------------------------------------- -- | Void: used for datatypes without constructors -data V1 p +data V1 (p :: *) -- | Unit: used for constructors without arguments -data U1 p = U1 +data U1 (p :: *) = U1 deriving (Eq, Ord, Read, Show, Generic) -- | Used for marking occurrences of the parameter @@ -587,43 +599,37 @@ newtype Par1 p = Par1 { unPar1 :: p } deriving (Eq, Ord, Read, Show, Generic) -- | Recursive calls of kind * -> * -newtype Rec1 f p = Rec1 { unRec1 :: f p } +newtype Rec1 f (p :: *) = Rec1 { unRec1 :: f p } deriving (Eq, Ord, Read, Show, Generic) -- | Constants, additional parameters and recursion of kind * -newtype K1 i c p = K1 { unK1 :: c } +newtype K1 (i :: *) c (p :: *) = K1 { unK1 :: c } deriving (Eq, Ord, Read, Show, Generic) -- | Meta-information (constructor names, etc.) -newtype M1 i c f p = M1 { unM1 :: f p } +newtype M1 (i :: *) (c :: Meta) f (p :: *) = M1 { unM1 :: f p } deriving (Eq, Ord, Read, Show, Generic) -- | Sums: encode choice between constructors infixr 5 :+: -data (:+:) f g p = L1 (f p) | R1 (g p) +data (:+:) f g (p :: *) = L1 (f p) | R1 (g p) deriving (Eq, Ord, Read, Show, Generic) -- | Products: encode multiple arguments to constructors infixr 6 :*: -data (:*:) f g p = f p :*: g p +data (:*:) f g (p :: *) = f p :*: g p deriving (Eq, Ord, Read, Show, Generic) -- | Composition of functors infixr 7 :.: -newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) } +newtype (:.:) f (g :: * -> *) (p :: *) = Comp1 { unComp1 :: f (g p) } deriving (Eq, Ord, Read, Show, Generic) -- | Tag for K1: recursion (of kind *) data R --- | Tag for K1: parameters (other than the last) -data P -- | Type synonym for encoding recursion (of kind *) type Rec0 = K1 R --- | Type synonym for encoding parameters (other than the last) -type Par0 = K1 P -{-# DEPRECATED Par0 "'Par0' is no longer used; use 'Rec0' instead" #-} -- deprecated in 7.6 -{-# DEPRECATED P "'P' is no longer used; use 'R' instead" #-} -- deprecated in 7.6 -- | Tag for M1: datatype data D @@ -652,16 +658,11 @@ class Datatype d where isNewtype :: t d (f :: * -> *) a -> Bool isNewtype _ = False - --- | Class for datatypes that represent records -class Selector s where - -- | The name of the selector - selName :: t s (f :: * -> *) a -> [Char] - --- | Used for constructor fields without a name -data NoSelector - -instance Selector NoSelector where selName _ = "" +instance (KnownSymbol n, KnownSymbol m, SingI nt) + => Datatype (MetaData n m nt) where + datatypeName _ = symbolVal (Proxy :: Proxy n) + moduleName _ = symbolVal (Proxy :: Proxy m) + isNewtype _ = fromSing (sing :: Sing nt) -- | Class for datatypes that represent data constructors class Constructor c where @@ -676,26 +677,46 @@ class Constructor c where conIsRecord :: t c (f :: * -> *) a -> Bool conIsRecord _ = False +instance (KnownSymbol n, SingI f, SingI r) => Constructor (MetaCons n f r) where + conName _ = symbolVal (Proxy :: Proxy n) + conFixity _ = fromSing (sing :: Sing f) + conIsRecord _ = fromSing (sing :: Sing r) --- | Datatype to represent the arity of a tuple. -data Arity = NoArity | Arity Int - deriving (Eq, Show, Ord, Read, Generic) -- | Datatype to represent the fixity of a constructor. An infix -- | declaration directly corresponds to an application of 'Infix'. data Fixity = Prefix | Infix Associativity Int - deriving (Eq, Show, Ord, Read, Generic) + -- deriving (Eq, Show, Ord, Read, Generic) +data FixityI = PrefixI | InfixI Associativity Nat -- | Get the precedence of a fixity value. prec :: Fixity -> Int prec Prefix = 10 prec (Infix _ n) = n + -- | Datatype to represent the associativity of a constructor data Associativity = LeftAssociative | RightAssociative | NotAssociative - deriving (Eq, Show, Ord, Read, Generic) + -- deriving (Eq, Show, Ord, Read, Generic) + +-- | Class for datatypes that represent records +class Selector s where + -- | The name of the selector + selName :: t s (f :: * -> *) a -> [Char] + +-- | Used for constructor fields without a name +-- Deprecated in 7.9 +{-# DEPRECATED NoSelector "'NoSelector' is no longer used" #-} +data NoSelector +instance Selector NoSelector where selName _ = "" + +-- instance Selector (MetaSel Nothing) where selName _ = "" +-- instance (KnownSymbol s) => Selector (MetaSel (Just s)) where + -- selName _ = symbolVal (Proxy :: Proxy s) +instance (KnownSymbol s) => Selector (MetaSel s) where + selName _ = symbolVal (Proxy :: Proxy s) -- | Representable types of kind *. -- This class is derivable in GHC with the DeriveGeneric flag on. @@ -718,10 +739,19 @@ class Generic1 f where -- | Convert from the representation to the datatype to1 :: (Rep1 f) a -> f a +-------------------------------------------------------------------------------- +-- Meta-data +-------------------------------------------------------------------------------- + +data Meta = MetaData Symbol Symbol Bool + | MetaCons Symbol FixityI Bool + -- | MetaSel (Maybe Symbol) + | MetaSel Symbol -------------------------------------------------------------------------------- -- Derived instances -------------------------------------------------------------------------------- + deriving instance Generic [a] deriving instance Generic (Maybe a) deriving instance Generic (Either a b) @@ -748,7 +778,7 @@ deriving instance Generic1 ((,,,,,,) a b c d e f) -------------------------------------------------------------------------------- -- Primitive representations -------------------------------------------------------------------------------- - +{- -- Int data D_Int data C_Int @@ -815,5 +845,97 @@ instance Generic Char where type Rep Char = D1 D_Char (C1 C_Char (S1 NoSelector (Rec0 Char))) from x = M1 (M1 (M1 (K1 x))) to (M1 (M1 (M1 (K1 x)))) = x +-} +-- deriving instance Generic (Proxy t) + + +-------------------------------------------------------------------------------- +-- Copied from the singletons package +-------------------------------------------------------------------------------- -deriving instance Generic (Proxy t) +-- | Convenient synonym to refer to the kind of a type variable: +-- @type KindOf (a :: k) = ('KProxy :: KProxy k)@ +-- type KindOf (a :: k) = ('KProxy :: KProxy k) + +-- | The singleton kind-indexed data family. +data family Sing (a :: k) + +-- | A 'SingI' constraint is essentially an implicitly-passed singleton. +-- If you need to satisfy this constraint with an explicit singleton, please +-- see 'withSingI'. +class SingI (a :: k) where + -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ + -- extension to use this method the way you want. + sing :: Sing a + +-- | The 'SingKind' class is essentially a /kind/ class. It classifies all kinds +-- for which singletons are defined. The class supports converting between a singleton +-- type and the base (unrefined) type which it is built from. +class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where + -- | Get a base type from a proxy for the promoted kind. For example, + -- @DemoteRep ('KProxy :: KProxy Bool)@ will be the type @Bool@. + type DemoteRep kparam :: * + + -- | Convert a singleton to its unrefined version. + fromSing :: Sing (a :: k) -> DemoteRep kparam + + -- Convert an unrefined type to an existentially-quantified singleton type. + -- toSing :: DemoteRep kparam -> SomeSing kparam + +-- | Convenient abbreviation for 'DemoteRep': +-- @type Demote (a :: k) = DemoteRep ('KProxy :: KProxy k)@ +-- type Demote (a :: k) = DemoteRep ('KProxy :: KProxy k) + +-- | An /existentially-quantified/ singleton. This type is useful when you want a +-- singleton type, but there is no way of knowing, at compile-time, what the type +-- index will be. To make use of this type, you will generally have to use a +-- pattern-match: +-- +-- > foo :: Bool -> ... +-- > foo b = case toSing b of +-- > SomeSing sb -> {- fancy dependently-typed code with sb -} +-- +-- An example like the one above may be easier to write using 'withSomeSing'. + +-- Singleton booleans +data instance Sing (a :: Bool) where + STrue :: Sing True + SFalse :: Sing False + +instance SingI True where sing = STrue +instance SingI False where sing = SFalse + +instance SingKind ('KProxy :: KProxy Bool) where + type DemoteRep ('KProxy :: KProxy Bool) = Bool + fromSing STrue = True + fromSing SFalse = False + +-- Singleton Fixity +data instance Sing (a :: FixityI) where + SPrefix :: Sing PrefixI + SInfix :: Sing a -> Integer -> Sing (InfixI a n) + +instance SingI PrefixI where sing = SPrefix +instance (SingI a, KnownNat n) => SingI (InfixI a n) where + sing = SInfix (sing :: Sing a) (natVal (Proxy :: Proxy n)) + +instance SingKind ('KProxy :: KProxy FixityI) where + type DemoteRep ('KProxy :: KProxy FixityI) = Fixity + fromSing SPrefix = Prefix + fromSing (SInfix a n) = Infix (fromSing a) (I# (integerToInt n)) + +-- Singleton Associativity +data instance Sing (a :: Associativity) where + SLeftAssociative :: Sing LeftAssociative + SRightAssociative :: Sing RightAssociative + SNotAssociative :: Sing NotAssociative + +instance SingI LeftAssociative where sing = SLeftAssociative +instance SingI RightAssociative where sing = SRightAssociative +instance SingI NotAssociative where sing = SNotAssociative + +instance SingKind ('KProxy :: KProxy Associativity) where + type DemoteRep ('KProxy :: KProxy Associativity) = Associativity + fromSing SLeftAssociative = LeftAssociative + fromSing SRightAssociative = RightAssociative + fromSing SNotAssociative = NotAssociative diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index f9b07605b9..edc277254b 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -2,7 +2,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 8, types: 19, coercions: 1} -T2431.$WRefl [InlPrag=INLINE] :: forall a. a T2431.:~: a +T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a [GblId[DataConWrapper], Caf=NoCafRefs, Str=DmdType, @@ -12,12 +12,9 @@ T2431.$WRefl [InlPrag=INLINE] :: forall a. a T2431.:~: a Tmpl= \ (@ a) -> T2431.Refl @ a @ a @~ <a>_N}] T2431.$WRefl = \ (@ a) -> T2431.Refl @ a @ a @~ <a>_N -T2431.absurd - :: forall a. GHC.Types.Int T2431.:~: GHC.Types.Bool -> a +absurd :: forall a. Int :~: Bool -> a [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>b] -T2431.absurd = - \ (@ a) (x :: GHC.Types.Int T2431.:~: GHC.Types.Bool) -> - case x of _ [Occ=Dead] { } +absurd = \ (@ a) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { } diff --git a/testsuite/tests/deriving/should_fail/T9071.stderr b/testsuite/tests/deriving/should_fail/T9071.stderr index 259adbaef0..3a09c8ecd5 100644 --- a/testsuite/tests/deriving/should_fail/T9071.stderr +++ b/testsuite/tests/deriving/should_fail/T9071.stderr @@ -2,7 +2,7 @@ [2 of 2] Compiling T9071 ( T9071.hs, T9071.o ) T9071.hs:7:37: - No instance for (Functor K) + No instance for (Functor Mu) arising from the first field of ‘F’ (type ‘Mu (K a)’) Possible fix: use a standalone 'deriving instance' declaration, diff --git a/testsuite/tests/deriving/should_fail/T9071_2.stderr b/testsuite/tests/deriving/should_fail/T9071_2.stderr index ae0fcdb928..65ba471c40 100644 --- a/testsuite/tests/deriving/should_fail/T9071_2.stderr +++ b/testsuite/tests/deriving/should_fail/T9071_2.stderr @@ -1,6 +1,6 @@ T9071_2.hs:7:40: - No instance for (Functor Mu) + No instance for (Functor K1) arising from the first field of ‘F1’ (type ‘Mu (K1 a)’) Possible fix: use a standalone 'deriving instance' declaration, diff --git a/testsuite/tests/deriving/should_fail/T9687.hs b/testsuite/tests/deriving/should_fail/T9687.hs new file mode 100644 index 0000000000..818878b215 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T9687.hs @@ -0,0 +1,4 @@ +module T9687 where +import Data.Typeable + +instance Typeable (a,b,c,d,e,f,g,h) diff --git a/testsuite/tests/deriving/should_fail/T9687.stderr b/testsuite/tests/deriving/should_fail/T9687.stderr new file mode 100644 index 0000000000..10619a6575 --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T9687.stderr @@ -0,0 +1,5 @@ + +T9687.hs:4:10: + Typeable instances can only be derived + Try ‘deriving instance Typeable (,,,,,,,)’ + (requires StandaloneDeriving) diff --git a/testsuite/tests/deriving/should_fail/T9730.stderr b/testsuite/tests/deriving/should_fail/T9730.stderr new file mode 100644 index 0000000000..0519ecba6e --- /dev/null +++ b/testsuite/tests/deriving/should_fail/T9730.stderr @@ -0,0 +1 @@ +
\ No newline at end of file diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T index 7700d62be1..54a6f95afc 100644 --- a/testsuite/tests/deriving/should_fail/all.T +++ b/testsuite/tests/deriving/should_fail/all.T @@ -51,4 +51,5 @@ test('T6147', normal, compile_fail, ['']) test('T8851', normal, compile_fail, ['']) test('T9071', normal, multimod_compile_fail, ['T9071','']) test('T9071_2', normal, compile_fail, ['']) +test('T9687', normal, compile_fail, ['']) diff --git a/testsuite/tests/gadt/T3169.stderr b/testsuite/tests/gadt/T3169.stderr index 09276728e2..a646a56462 100644 --- a/testsuite/tests/gadt/T3169.stderr +++ b/testsuite/tests/gadt/T3169.stderr @@ -1,8 +1,6 @@ T3169.hs:13:22: - Could not deduce (elt ~ Map b elt) - from the context (Key a, Key b) - bound by the instance declaration at T3169.hs:10:10-36 + Couldn't match type ‘elt’ with ‘Map b elt’ ‘elt’ is a rigid type variable bound by the type signature for lookup :: (a, b) -> Map (a, b) elt -> Maybe elt diff --git a/testsuite/tests/gadt/T7293.stderr b/testsuite/tests/gadt/T7293.stderr index d9719ba65b..3e5d9ddf8f 100644 --- a/testsuite/tests/gadt/T7293.stderr +++ b/testsuite/tests/gadt/T7293.stderr @@ -1,6 +1,6 @@ T7293.hs:24:5: - Couldn't match type ‘'False’ with ‘'True’ + Couldn't match type ‘'True’ with ‘'False’ Inaccessible code in a pattern with constructor Nil :: forall a. Vec a 'Zero, diff --git a/testsuite/tests/gadt/T7294.stderr b/testsuite/tests/gadt/T7294.stderr index f5ad94601b..b5e4e56f35 100644 --- a/testsuite/tests/gadt/T7294.stderr +++ b/testsuite/tests/gadt/T7294.stderr @@ -1,6 +1,6 @@ T7294.hs:25:5: Warning: - Couldn't match type ‘'False’ with ‘'True’ + Couldn't match type ‘'True’ with ‘'False’ Inaccessible code in a pattern with constructor Nil :: forall a. Vec a 'Zero, diff --git a/testsuite/tests/gadt/gadt21.stderr b/testsuite/tests/gadt/gadt21.stderr index 5c234daf99..9b29cba4c0 100644 --- a/testsuite/tests/gadt/gadt21.stderr +++ b/testsuite/tests/gadt/gadt21.stderr @@ -1,19 +1,14 @@ - -gadt21.hs:21:60: - Could not deduce (Ord a1) arising from a use of ‘f’ - from the context (a ~ Set a1) - bound by a pattern with constructor - TypeSet :: forall a. Type a -> Type (Set a), - in an equation for ‘withOrdDynExpr’ - at gadt21.hs:21:35-43 - Possible fix: - add (Ord a1) to the context of - the data constructor ‘TypeSet’ - or the data constructor ‘DynExpr’ - or the type signature for - withOrdDynExpr :: DynExpr - -> (forall a. Ord a => Expr a -> b) -> Maybe b - In the first argument of ‘Just’, namely ‘(f e)’ - In the expression: Just (f e) - In an equation for ‘withOrdDynExpr’: - withOrdDynExpr (DynExpr e@(Const (TypeSet _) _)) f = Just (f e) +
+gadt21.hs:21:60:
+ Could not deduce (Ord a1) arising from a use of ‘f’
+ from the context (a ~ Set a1)
+ bound by a pattern with constructor
+ TypeSet :: forall a. Type a -> Type (Set a),
+ in an equation for ‘withOrdDynExpr’
+ at gadt21.hs:21:35-43
+ Possible fix:
+ add (Ord a1) to the context of the data constructor ‘TypeSet’
+ In the first argument of ‘Just’, namely ‘(f e)’
+ In the expression: Just (f e)
+ In an equation for ‘withOrdDynExpr’:
+ withOrdDynExpr (DynExpr e@(Const (TypeSet _) _)) f = Just (f e)
diff --git a/testsuite/tests/generics/GShow/GShow.hs b/testsuite/tests/generics/GShow/GShow.hs index 3c8f2591ef..e05bcb7f76 100644 --- a/testsuite/tests/generics/GShow/GShow.hs +++ b/testsuite/tests/generics/GShow/GShow.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE IncoherentInstances #-} -- :-/ {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE PolyKinds #-} module GShow ( -- * Generic show class diff --git a/testsuite/tests/generics/GenDerivOutput.stderr b/testsuite/tests/generics/GenDerivOutput.stderr index b47b3f3e42..0492bcbfa1 100644 --- a/testsuite/tests/generics/GenDerivOutput.stderr +++ b/testsuite/tests/generics/GenDerivOutput.stderr @@ -88,102 +88,98 @@ Derived instances: ((GHC.Base..) (GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g2) - instance GHC.Generics.Datatype GenDerivOutput.D1List where - GHC.Generics.datatypeName _ = "List" - GHC.Generics.moduleName _ = "GenDerivOutput" - instance GHC.Generics.Constructor GenDerivOutput.C1_0List where - GHC.Generics.conName _ = "Nil" - - instance GHC.Generics.Constructor GenDerivOutput.C1_1List where - GHC.Generics.conName _ = "Cons" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector GenDerivOutput.S1_1_0List where - GHC.Generics.selName _ = "element" - - instance GHC.Generics.Selector GenDerivOutput.S1_1_1List where - GHC.Generics.selName _ = "rest" - - instance GHC.Generics.Datatype GenDerivOutput.D1Rose where - GHC.Generics.datatypeName _ = "Rose" - GHC.Generics.moduleName _ = "GenDerivOutput" - - instance GHC.Generics.Constructor GenDerivOutput.C1_0Rose where - GHC.Generics.conName _ = "Empty" - - instance GHC.Generics.Constructor GenDerivOutput.C1_1Rose where - GHC.Generics.conName _ = "Rose" - - -Generic representation: - - Generated datatypes for meta-information: - GenDerivOutput.D1List - GenDerivOutput.C1_0List - GenDerivOutput.C1_1List - GenDerivOutput.S1_1_0List - GenDerivOutput.S1_1_1List - GenDerivOutput.D1Rose - GenDerivOutput.C1_0Rose - GenDerivOutput.C1_1Rose - GenDerivOutput.S1_1_0Rose - GenDerivOutput.S1_1_1Rose - - Representation types: +GHC.Generics representation types: type GHC.Generics.Rep (GenDerivOutput.List a) = GHC.Generics.D1 - GenDerivOutput.D1List + ('GHC.Generics.MetaData + "List" "GenDerivOutput" 'GHC.Types.False) (GHC.Generics.C1 - GenDerivOutput.C1_0List GHC.Generics.U1 + ('GHC.Generics.MetaCons + "Nil" + 'GHC.Generics.PrefixI + 'GHC.Types.False) + GHC.Generics.U1 GHC.Generics.:+: GHC.Generics.C1 - GenDerivOutput.C1_1List + ('GHC.Generics.MetaCons + "Cons" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - GenDerivOutput.S1_1_0List + ('GHC.Generics.MetaSel + "element") (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 - GenDerivOutput.S1_1_1List + ('GHC.Generics.MetaSel + "rest") (GHC.Generics.Rec0 (GenDerivOutput.List a)))) type GHC.Generics.Rep1 GenDerivOutput.List = GHC.Generics.D1 - GenDerivOutput.D1List + ('GHC.Generics.MetaData + "List" "GenDerivOutput" 'GHC.Types.False) (GHC.Generics.C1 - GenDerivOutput.C1_0List GHC.Generics.U1 + ('GHC.Generics.MetaCons + "Nil" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 GHC.Generics.:+: GHC.Generics.C1 - GenDerivOutput.C1_1List + ('GHC.Generics.MetaCons + "Cons" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - GenDerivOutput.S1_1_0List + ('GHC.Generics.MetaSel + "element") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - GenDerivOutput.S1_1_1List + ('GHC.Generics.MetaSel + "rest") (GHC.Generics.Rec1 GenDerivOutput.List))) type GHC.Generics.Rep (GenDerivOutput.Rose a) = GHC.Generics.D1 - GenDerivOutput.D1Rose + ('GHC.Generics.MetaData + "Rose" "GenDerivOutput" 'GHC.Types.False) (GHC.Generics.C1 - GenDerivOutput.C1_0Rose GHC.Generics.U1 + ('GHC.Generics.MetaCons + "Empty" + 'GHC.Generics.PrefixI + 'GHC.Types.False) + GHC.Generics.U1 GHC.Generics.:+: GHC.Generics.C1 - GenDerivOutput.C1_1Rose + ('GHC.Generics.MetaCons + "Rose" + 'GHC.Generics.PrefixI + 'GHC.Types.False) (GHC.Generics.S1 - GHC.Generics.NoSelector + ('GHC.Generics.MetaSel + "") (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 - GHC.Generics.NoSelector + ('GHC.Generics.MetaSel + "") (GHC.Generics.Rec0 (GenDerivOutput.List (GenDerivOutput.Rose a))))) type GHC.Generics.Rep1 GenDerivOutput.Rose = GHC.Generics.D1 - GenDerivOutput.D1Rose + ('GHC.Generics.MetaData + "Rose" "GenDerivOutput" 'GHC.Types.False) (GHC.Generics.C1 - GenDerivOutput.C1_0Rose GHC.Generics.U1 + ('GHC.Generics.MetaCons + "Empty" + 'GHC.Generics.PrefixI + 'GHC.Types.False) + GHC.Generics.U1 GHC.Generics.:+: GHC.Generics.C1 - GenDerivOutput.C1_1Rose + ('GHC.Generics.MetaCons + "Rose" + 'GHC.Generics.PrefixI + 'GHC.Types.False) (GHC.Generics.S1 - GHC.Generics.NoSelector + ('GHC.Generics.MetaSel "") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - GHC.Generics.NoSelector + ('GHC.Generics.MetaSel + "") (GenDerivOutput.List GHC.Generics.:.: GHC.Generics.Rec1 GenDerivOutput.Rose))) diff --git a/testsuite/tests/generics/GenDerivOutput1_0.stderr b/testsuite/tests/generics/GenDerivOutput1_0.stderr index 222d2d3165..02a41c3b1e 100644 --- a/testsuite/tests/generics/GenDerivOutput1_0.stderr +++ b/testsuite/tests/generics/GenDerivOutput1_0.stderr @@ -21,45 +21,29 @@ Derived instances: = GenDerivOutput1_0.Cons (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) - instance GHC.Generics.Datatype GenDerivOutput1_0.D1List where - GHC.Generics.datatypeName _ = "List" - GHC.Generics.moduleName _ = "GenDerivOutput1_0" - instance GHC.Generics.Constructor GenDerivOutput1_0.C1_0List where - GHC.Generics.conName _ = "Nil" - - instance GHC.Generics.Constructor GenDerivOutput1_0.C1_1List where - GHC.Generics.conName _ = "Cons" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector GenDerivOutput1_0.S1_1_0List where - GHC.Generics.selName _ = "element" - - instance GHC.Generics.Selector GenDerivOutput1_0.S1_1_1List where - GHC.Generics.selName _ = "rest" - - -Generic representation: - - Generated datatypes for meta-information: - GenDerivOutput1_0.D1List - GenDerivOutput1_0.C1_0List - GenDerivOutput1_0.C1_1List - GenDerivOutput1_0.S1_1_0List - GenDerivOutput1_0.S1_1_1List - - Representation types: +GHC.Generics representation types: type GHC.Generics.Rep1 GenDerivOutput1_0.List = GHC.Generics.D1 - GenDerivOutput1_0.D1List + ('GHC.Generics.MetaData + "List" "GenDerivOutput1_0" 'GHC.Types.False) (GHC.Generics.C1 - GenDerivOutput1_0.C1_0List GHC.Generics.U1 + ('GHC.Generics.MetaCons + "Nil" + 'GHC.Generics.PrefixI + 'GHC.Types.False) + GHC.Generics.U1 GHC.Generics.:+: GHC.Generics.C1 - GenDerivOutput1_0.C1_1List + ('GHC.Generics.MetaCons + "Cons" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - GenDerivOutput1_0.S1_1_0List + ('GHC.Generics.MetaSel + "element") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - GenDerivOutput1_0.S1_1_1List + ('GHC.Generics.MetaSel + "rest") (GHC.Generics.Rec1 GenDerivOutput1_0.List))) diff --git a/testsuite/tests/generics/GenDerivOutput1_1.stderr b/testsuite/tests/generics/GenDerivOutput1_1.stderr index 6b9f546990..b4f73b82c0 100644 --- a/testsuite/tests/generics/GenDerivOutput1_1.stderr +++ b/testsuite/tests/generics/GenDerivOutput1_1.stderr @@ -153,198 +153,170 @@ Derived instances: (GHC.Generics.M1 g2))))) = CanDoRep1_1.D1c (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) - instance GHC.Generics.Datatype CanDoRep1_1.D1Da where - GHC.Generics.datatypeName _ = "Da" - GHC.Generics.moduleName _ = "CanDoRep1_1" - instance GHC.Generics.Constructor CanDoRep1_1.C1_0Da where - GHC.Generics.conName _ = "D0" - - instance GHC.Generics.Constructor CanDoRep1_1.C1_1Da where - GHC.Generics.conName _ = "D1" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector CanDoRep1_1.S1_1_0Da where - GHC.Generics.selName _ = "d11a" - - instance GHC.Generics.Selector CanDoRep1_1.S1_1_1Da where - GHC.Generics.selName _ = "d12a" - - instance GHC.Generics.Datatype CanDoRep1_1.D1Db where - GHC.Generics.datatypeName _ = "Db" - GHC.Generics.moduleName _ = "CanDoRep1_1" - - instance GHC.Generics.Constructor CanDoRep1_1.C1_0Db where - GHC.Generics.conName _ = "D0b" - - instance GHC.Generics.Constructor CanDoRep1_1.C1_1Db where - GHC.Generics.conName _ = "D1b" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector CanDoRep1_1.S1_1_0Db where - GHC.Generics.selName _ = "d11b" - - instance GHC.Generics.Selector CanDoRep1_1.S1_1_1Db where - GHC.Generics.selName _ = "d12b" - - instance GHC.Generics.Datatype CanDoRep1_1.D1Dc where - GHC.Generics.datatypeName _ = "Dc" - GHC.Generics.moduleName _ = "CanDoRep1_1" - - instance GHC.Generics.Constructor CanDoRep1_1.C1_0Dc where - GHC.Generics.conName _ = "D0c" - - instance GHC.Generics.Constructor CanDoRep1_1.C1_1Dc where - GHC.Generics.conName _ = "D1c" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector CanDoRep1_1.S1_1_0Dc where - GHC.Generics.selName _ = "d11c" - - instance GHC.Generics.Selector CanDoRep1_1.S1_1_1Dc where - GHC.Generics.selName _ = "d12c" - - instance GHC.Generics.Datatype CanDoRep1_1.D1Dd where - GHC.Generics.datatypeName _ = "Dd" - GHC.Generics.moduleName _ = "CanDoRep1_1" - - instance GHC.Generics.Constructor CanDoRep1_1.C1_0Dd where - GHC.Generics.conName _ = "D0d" - - instance GHC.Generics.Constructor CanDoRep1_1.C1_1Dd where - GHC.Generics.conName _ = "D1d" - GHC.Generics.conIsRecord _ = GHC.Types.True - - instance GHC.Generics.Selector CanDoRep1_1.S1_1_0Dd where - GHC.Generics.selName _ = "d11d" - - instance GHC.Generics.Selector CanDoRep1_1.S1_1_1Dd where - GHC.Generics.selName _ = "d12d" - - -Generic representation: - - Generated datatypes for meta-information: - CanDoRep1_1.D1Da - CanDoRep1_1.C1_0Da - CanDoRep1_1.C1_1Da - CanDoRep1_1.S1_1_0Da - CanDoRep1_1.S1_1_1Da - CanDoRep1_1.D1Db - CanDoRep1_1.C1_0Db - CanDoRep1_1.C1_1Db - CanDoRep1_1.S1_1_0Db - CanDoRep1_1.S1_1_1Db - CanDoRep1_1.D1Dc - CanDoRep1_1.C1_0Dc - CanDoRep1_1.C1_1Dc - CanDoRep1_1.S1_1_0Dc - CanDoRep1_1.S1_1_1Dc - CanDoRep1_1.D1Dd - CanDoRep1_1.C1_0Dd - CanDoRep1_1.C1_1Dd - CanDoRep1_1.S1_1_0Dd - CanDoRep1_1.S1_1_1Dd - - Representation types: +GHC.Generics representation types: type GHC.Generics.Rep1 CanDoRep1_1.Dd = GHC.Generics.D1 - CanDoRep1_1.D1Dd - (GHC.Generics.C1 CanDoRep1_1.C1_0Dd GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1Dd + ('GHC.Generics.MetaData + "Dd" "CanDoRep1_1" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0d" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1d" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0Dd + ('GHC.Generics.MetaSel "d11d") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1Dd + ('GHC.Generics.MetaSel + "d12d") (GHC.Generics.Rec1 CanDoRep1_1.Dd))) type GHC.Generics.Rep (CanDoRep1_1.Dd a) = GHC.Generics.D1 - CanDoRep1_1.D1Dd - (GHC.Generics.C1 CanDoRep1_1.C1_0Dd GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1Dd + ('GHC.Generics.MetaData + "Dd" "CanDoRep1_1" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0d" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1d" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0Dd + ('GHC.Generics.MetaSel "d11d") (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1Dd + ('GHC.Generics.MetaSel + "d12d") (GHC.Generics.Rec0 (CanDoRep1_1.Dd a)))) type GHC.Generics.Rep (CanDoRep1_1.Dc a) = GHC.Generics.D1 - CanDoRep1_1.D1Dc - (GHC.Generics.C1 CanDoRep1_1.C1_0Dc GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1Dc + ('GHC.Generics.MetaData + "Dc" "CanDoRep1_1" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0c" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1c" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0Dc + ('GHC.Generics.MetaSel "d11c") (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1Dc + ('GHC.Generics.MetaSel + "d12c") (GHC.Generics.Rec0 (CanDoRep1_1.Dc a)))) type GHC.Generics.Rep1 CanDoRep1_1.Db = GHC.Generics.D1 - CanDoRep1_1.D1Db - (GHC.Generics.C1 CanDoRep1_1.C1_0Db GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1Db + ('GHC.Generics.MetaData + "Db" "CanDoRep1_1" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0b" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1b" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0Db + ('GHC.Generics.MetaSel "d11b") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1Db + ('GHC.Generics.MetaSel + "d12b") (GHC.Generics.Rec1 CanDoRep1_1.Db))) type GHC.Generics.Rep (CanDoRep1_1.Da a) = GHC.Generics.D1 - CanDoRep1_1.D1Da - (GHC.Generics.C1 CanDoRep1_1.C1_0Da GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1Da + ('GHC.Generics.MetaData + "Da" "CanDoRep1_1" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0Da + ('GHC.Generics.MetaSel "d11a") (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1Da + ('GHC.Generics.MetaSel + "d12a") (GHC.Generics.Rec0 (CanDoRep1_1.Da a)))) type GHC.Generics.Rep1 CanDoRep1_1.Da = GHC.Generics.D1 - CanDoRep1_1.D1Da - (GHC.Generics.C1 CanDoRep1_1.C1_0Da GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1Da + ('GHC.Generics.MetaData + "Da" "CanDoRep1_1" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0Da + ('GHC.Generics.MetaSel "d11a") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1Da + ('GHC.Generics.MetaSel + "d12a") (GHC.Generics.Rec1 CanDoRep1_1.Da))) type GHC.Generics.Rep (CanDoRep1_1.Db a) = GHC.Generics.D1 - CanDoRep1_1.D1Db - (GHC.Generics.C1 CanDoRep1_1.C1_0Db GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1Db + ('GHC.Generics.MetaData + "Db" "CanDoRep1_1" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0b" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1b" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0Db + ('GHC.Generics.MetaSel "d11b") (GHC.Generics.Rec0 a) GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1Db + ('GHC.Generics.MetaSel + "d12b") (GHC.Generics.Rec0 (CanDoRep1_1.Db a)))) type GHC.Generics.Rep1 CanDoRep1_1.Dc = GHC.Generics.D1 - CanDoRep1_1.D1Dc - (GHC.Generics.C1 CanDoRep1_1.C1_0Dc GHC.Generics.U1 - GHC.Generics.:+: GHC.Generics.C1 - CanDoRep1_1.C1_1Dc + ('GHC.Generics.MetaData + "Dc" "CanDoRep1_1" 'GHC.Types.False) + (GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D0c" 'GHC.Generics.PrefixI 'GHC.Types.False) + GHC.Generics.U1 + GHC.Generics.:+: GHC.Generics.C1 + ('GHC.Generics.MetaCons + "D1c" + 'GHC.Generics.PrefixI + 'GHC.Types.True) (GHC.Generics.S1 - CanDoRep1_1.S1_1_0Dc + ('GHC.Generics.MetaSel "d11c") GHC.Generics.Par1 GHC.Generics.:*: GHC.Generics.S1 - CanDoRep1_1.S1_1_1Dc + ('GHC.Generics.MetaSel + "d12c") (GHC.Generics.Rec1 CanDoRep1_1.Dc))) diff --git a/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr b/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr index 54915f2953..69b9996223 100644 --- a/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr +++ b/testsuite/tests/ghc-api/apirecomp001/apirecomp001.stderr @@ -3,14 +3,14 @@ B.hs:4:1: Warning: Top-level binding with no type signature: answer_to_live_the_universe_and_everything :: Int -B.hs:5:13: Warning: +B.hs:5:12: Warning: Defaulting the following constraint(s) to type ‘Integer’ - (Num a0) arising from the literal ‘1’ at B.hs:5:13 (Enum a0) arising from the arithmetic sequence ‘1 .. 23 * 2’ at B.hs:5:12-20 - In the expression: 1 + (Num a0) arising from the literal ‘1’ at B.hs:5:13 In the first argument of ‘length’, namely ‘[1 .. 23 * 2]’ In the first argument of ‘(-)’, namely ‘length [1 .. 23 * 2]’ + In the expression: length [1 .. 23 * 2] - 4 A.hs:7:1: Warning: Top-level binding with no type signature: main :: IO () @@ -19,14 +19,14 @@ B.hs:4:1: Warning: Top-level binding with no type signature: answer_to_live_the_universe_and_everything :: Int -B.hs:5:13: Warning: +B.hs:5:12: Warning: Defaulting the following constraint(s) to type ‘Integer’ - (Num a0) arising from the literal ‘1’ at B.hs:5:13 (Enum a0) arising from the arithmetic sequence ‘1 .. 23 * 2’ at B.hs:5:12-20 - In the expression: 1 + (Num a0) arising from the literal ‘1’ at B.hs:5:13 In the first argument of ‘length’, namely ‘[1 .. 23 * 2]’ In the first argument of ‘(-)’, namely ‘length [1 .. 23 * 2]’ + In the expression: length [1 .. 23 * 2] - 4 A.hs:7:1: Warning: Top-level binding with no type signature: main :: IO () diff --git a/testsuite/tests/ghci.debugger/scripts/break026.stdout b/testsuite/tests/ghci.debugger/scripts/break026.stdout index 9afc3f470e..8d81867044 100644 --- a/testsuite/tests/ghci.debugger/scripts/break026.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break026.stdout @@ -1,58 +1,58 @@ -Stopped at break026.hs:(5,1)-(7,35) -_result :: t = _ -Stopped at break026.hs:5:16-22 -_result :: Integer = _ -c :: Integer = 0 -go :: Integer -> [t1] -> Integer = _ -xs :: [t1] = _ -Stopped at break026.hs:(6,9)-(7,35) -_result :: t = _ -f :: t -> t1 -> t = _ -Stopped at break026.hs:7:23-35 -_result :: Integer = _ -c :: Integer = 0 -f :: Integer -> Integer -> Integer = _ -x :: Integer = 1 -xs :: [Integer] = _ -Stopped at break026.hs:(6,9)-(7,35) -_result :: t = _ -f :: t -> t1 -> t = _ -Stopped at break026.hs:7:23-35 -_result :: t = _ -c :: t = _ -f :: t -> Integer -> t = _ -x :: Integer = 2 -xs :: [Integer] = _ -c = 1 -Stopped at break026.hs:(5,1)-(7,35) -_result :: t = _ -Stopped at break026.hs:5:16-22 -_result :: Integer = _ -c :: Integer = 0 -go :: Integer -> [t1] -> Integer = _ -xs :: [t1] = _ -Stopped at break026.hs:(6,9)-(7,35) -_result :: t = _ -f :: t -> t1 -> t = _ -Stopped at break026.hs:7:23-35 -_result :: Integer = _ -c :: Integer = 0 -f :: Integer -> Integer -> Integer = _ -x :: Integer = 1 -xs :: [Integer] = _ -Stopped at break026.hs:(6,9)-(7,35) -_result :: t = _ -f :: t -> t1 -> t = _ -Stopped at break026.hs:7:23-35 -_result :: t = _ -c :: t = _ -f :: t -> Integer -> t = _ -x :: Integer = 2 -xs :: [Integer] = _ -Stopped at break026.hs:7:27-31 -_result :: Integer = _ -c :: Integer = 0 -f :: Integer -> Integer -> Integer = _ -x :: Integer = 1 -() -1 +Stopped at break026.hs:(5,1)-(7,35)
+_result :: t1 = _
+Stopped at break026.hs:5:16-22
+_result :: Integer = _
+c :: Integer = 0
+go :: Integer -> [t] -> Integer = _
+xs :: [t] = _
+Stopped at break026.hs:(6,9)-(7,35)
+_result :: t1 = _
+f :: t1 -> t -> t1 = _
+Stopped at break026.hs:7:23-35
+_result :: Integer = _
+c :: Integer = 0
+f :: Integer -> Integer -> Integer = _
+x :: Integer = 1
+xs :: [Integer] = _
+Stopped at break026.hs:(6,9)-(7,35)
+_result :: t1 = _
+f :: t1 -> t -> t1 = _
+Stopped at break026.hs:7:23-35
+_result :: t1 = _
+c :: t1 = _
+f :: t1 -> Integer -> t1 = _
+x :: Integer = 2
+xs :: [Integer] = _
+c = 1
+Stopped at break026.hs:(5,1)-(7,35)
+_result :: t1 = _
+Stopped at break026.hs:5:16-22
+_result :: Integer = _
+c :: Integer = 0
+go :: Integer -> [t] -> Integer = _
+xs :: [t] = _
+Stopped at break026.hs:(6,9)-(7,35)
+_result :: t1 = _
+f :: t1 -> t -> t1 = _
+Stopped at break026.hs:7:23-35
+_result :: Integer = _
+c :: Integer = 0
+f :: Integer -> Integer -> Integer = _
+x :: Integer = 1
+xs :: [Integer] = _
+Stopped at break026.hs:(6,9)-(7,35)
+_result :: t1 = _
+f :: t1 -> t -> t1 = _
+Stopped at break026.hs:7:23-35
+_result :: t1 = _
+c :: t1 = _
+f :: t1 -> Integer -> t1 = _
+x :: Integer = 2
+xs :: [Integer] = _
+Stopped at break026.hs:7:27-31
+_result :: Integer = _
+c :: Integer = 0
+f :: Integer -> Integer -> Integer = _
+x :: Integer = 1
+()
+1
diff --git a/testsuite/tests/indexed-types/should_compile/IndTypesPerfMerge.hs b/testsuite/tests/indexed-types/should_compile/IndTypesPerfMerge.hs index e37bfe323e..f011bcf465 100644 --- a/testsuite/tests/indexed-types/should_compile/IndTypesPerfMerge.hs +++ b/testsuite/tests/indexed-types/should_compile/IndTypesPerfMerge.hs @@ -41,6 +41,14 @@ class Mergeable a b where type MergerType a b merger :: a -> b -> MergerType a b +{- +merge :: + forall a b. + (Merger (MergerType a b), Mergeable a b, + UnmergedLeft (MergerType a b) ~ a, + UnmergedRight (MergerType a b) ~ b) => + a -> b -> Merged (MergerType a b) +-} merge x y = mkMerge (merger x y) x y data TakeRight a @@ -117,4 +125,4 @@ instance type Merged (RightHeadFirst h1 t1 h2 t2) = h2 :* Merged (MergerType (h1 :* t1) t2) type UnmergedLeft (RightHeadFirst h1 t1 h2 t2) = h1 :* t1 type UnmergedRight (RightHeadFirst h1 t1 h2 t2) = h2 :* t2 - mkMerge _ (h1 :* t1) (h2 :* t2) = h2 :* mkMerge (merger (h1 :* t1) t2) (h1 :* t1) t2
\ No newline at end of file + mkMerge _ (h1 :* t1) (h2 :* t2) = h2 :* mkMerge (merger (h1 :* t1) t2) (h1 :* t1) t2 diff --git a/testsuite/tests/indexed-types/should_compile/PushInAsGivens.stderr b/testsuite/tests/indexed-types/should_compile/PushInAsGivens.stderr new file mode 100644 index 0000000000..0519ecba6e --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/PushInAsGivens.stderr @@ -0,0 +1 @@ +
\ No newline at end of file diff --git a/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.hs b/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.hs index 0117b81d47..063f7021cf 100644 --- a/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.hs +++ b/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.hs @@ -8,7 +8,7 @@ type family F a bar y = let foo :: (F Int ~ [a]) => a -> Int
foo x = length [x,y]
- in (y,foo y)
+ in (y,foo y)
-- This example demonstrates why we need to push in
@@ -20,5 +20,12 @@ bar y = let foo :: (F Int ~ [a]) => a -> Int -- Given/Solved, it will be discarded when we meet the given (F Int ~ [a]) and
-- we will not be able to solve the implication constraint.
+-- Oct 14: actually this example is _really_ strange, and doesn't illustrate
+-- the real issue in Trac #4935, for which there is a separate test
+--
+-- The example here requires us to infer a type
+-- bar :: F Int ~ [a] => ...
+-- which is a strange type to quantify over; better to complain about
+-- having no instance for F Int.
diff --git a/testsuite/tests/indexed-types/should_compile/Simple13.hs b/testsuite/tests/indexed-types/should_compile/Simple13.hs index 7633f01f98..9e463e8e05 100644 --- a/testsuite/tests/indexed-types/should_compile/Simple13.hs +++ b/testsuite/tests/indexed-types/should_compile/Simple13.hs @@ -16,3 +16,33 @@ mkf p = undefined foo :: a ~ [F a] => a -> a foo p = same p (mkf p) +{- p :: a + + [G] g : a ~ [F a] + [W] w : a ~ [F a] + +---> + g' = g;[x] g'=aq4 + [G] g' : a ~ [fsk] g=aqW + [W] x : F a ~ fsk x=aq3 + + [W] w : a ~ [F a] + + --> subst a + x = F g' ; x2 + [W] x2 : F fsk ~ fsk x2=aq5 + + --> (subst a) + w = g' ; w2 + [W] w2 : [fsk] ~ [F a] + + --> decompose + w2 = [w3] + [W] w3 : fsk ~ F a + + + +cycle is + aq3 = Sym (F aq4) ; aq5 x = Sym (F g') ; x2 + aq4 = apw ; aq3 g' = +-} diff --git a/testsuite/tests/indexed-types/should_compile/Simple8.hs b/testsuite/tests/indexed-types/should_compile/Simple8.hs index f819763579..bc660bb8fa 100644 --- a/testsuite/tests/indexed-types/should_compile/Simple8.hs +++ b/testsuite/tests/indexed-types/should_compile/Simple8.hs @@ -8,7 +8,7 @@ type family F a -- works if one of the duplicates is removed. type instance F () = () -type instance F () = () +-- type instance F () = () foo :: F () -> () foo x = x diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr index 4e0677569e..ec97deaf18 100644 --- a/testsuite/tests/indexed-types/should_compile/T3017.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr @@ -1,7 +1,7 @@ TYPE SIGNATURES emptyL :: forall a. ListColl a test2 :: - forall c t t1. (Coll c, Num t1, Num t, Elem c ~ (t, t1)) => c -> c + forall c t t1. (Num t, Num t1, Coll c, Elem c ~ (t, t1)) => c -> c TYPE CONSTRUCTORS class Coll c where type family Elem c :: * open diff --git a/testsuite/tests/indexed-types/should_compile/T3208b.stderr b/testsuite/tests/indexed-types/should_compile/T3208b.stderr index a210113ea8..5ee40a7faf 100644 --- a/testsuite/tests/indexed-types/should_compile/T3208b.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3208b.stderr @@ -1,27 +1,24 @@ T3208b.hs:15:10: - Could not deduce (STerm o0 ~ STerm a) + Could not deduce (STerm o0 ~ OTerm o0) from the context (OTerm a ~ STerm a, OBJECT a, SUBST a) bound by the type signature for fce' :: (OTerm a ~ STerm a, OBJECT a, SUBST a) => a -> c at T3208b.hs:14:9-56 - NB: ‘STerm’ is a type function, and may not be injective The type variable ‘o0’ is ambiguous - Expected type: STerm o0 - Actual type: OTerm o0 - Relevant bindings include - f :: a (bound at T3208b.hs:15:6) - fce' :: a -> c (bound at T3208b.hs:15:1) In the expression: fce (apply f) In an equation for ‘fce'’: fce' f = fce (apply f) T3208b.hs:15:15: - Could not deduce (OTerm o0 ~ STerm a) + Could not deduce (OTerm o0 ~ OTerm a) from the context (OTerm a ~ STerm a, OBJECT a, SUBST a) bound by the type signature for fce' :: (OTerm a ~ STerm a, OBJECT a, SUBST a) => a -> c at T3208b.hs:14:9-56 + NB: ‘OTerm’ is a type function, and may not be injective The type variable ‘o0’ is ambiguous + Expected type: STerm a + Actual type: OTerm o0 Relevant bindings include f :: a (bound at T3208b.hs:15:6) fce' :: a -> c (bound at T3208b.hs:15:1) diff --git a/testsuite/tests/indexed-types/should_compile/T3826.hs b/testsuite/tests/indexed-types/should_compile/T3826.hs index 39c597f69c..752ba59735 100644 --- a/testsuite/tests/indexed-types/should_compile/T3826.hs +++ b/testsuite/tests/indexed-types/should_compile/T3826.hs @@ -6,10 +6,56 @@ class C a where type E a
c :: E a -> a -> a
-data T a = T a
+data T a = MkT a
+-- MkT :: a -> T a
-instance C (T a) where
- type E (T a) = a
- c x (T _) = T x
+instance C (T b) where
+ type E (T b) = b
+ c x (MkT _) = MkT x
+
+
+f t@(MkT x) = c x t
+
+{- c :: E alpha -> alpha -> alpha
+ t :: T beta
+ x :: beta
+ f :: T beta -> gamma
+
+
+ [W] C alpha
+ [W] E alpha ~ beta
+ [W] alpha ~ T beta
+ [W] gamma ~ alpha
+
+---> beta = t_aqf alpha = t_aqg
+ alpha := T beta
+ gamma := alpha
+
+ [W] E (T beta) ~ beta
+
+-->
+ [W] ufsk ~ beta
+ [W] E (T beta) ~ ufsk
+
+--> (swap and subst)
+ beta := ufsk
+ [W] x : E (T ufsk) ~ ufsk (do not rewrite RHS)
+
+take a step ax: E (T beta) ~ beta
+
+-->
+ [W] ufsk
+--------------------------
+ But what about this?
+--------------------------
+
+axiom F [a] = F [a]
+
+ x : F [a] ~ fsk
+step
+ ax : F [a] ~ F [a]
+flatten
+ ax ; x : F [a] ~ fsk
+ x = ax ; x Oh dear!
+-}
-f t@(T x) = c x t
diff --git a/testsuite/tests/indexed-types/should_compile/T4494.hs b/testsuite/tests/indexed-types/should_compile/T4494.hs index 52e1435272..ec04943d6b 100644 --- a/testsuite/tests/indexed-types/should_compile/T4494.hs +++ b/testsuite/tests/indexed-types/should_compile/T4494.hs @@ -10,3 +10,23 @@ bar = error "urk" call :: F Bool -> Int call x = bar (\_ -> x) (undefined :: H (F Bool)) + +{- + [W] H (F Bool) ~ H alpha + [W] alpha ~ F Bool +--> + F Bool ~ fuv0 + H fuv0 ~ fuv1 + H alpha ~ fuv2 + + fuv1 ~ fuv2 + alpha ~ fuv0 + +flatten +~~~~~~~ +fuv0 := alpha +fuv1 := fuv2 + +alpha := F Bool +-} + diff --git a/testsuite/tests/indexed-types/should_compile/T7804.hs b/testsuite/tests/indexed-types/should_compile/T7804.hs index 6521022e3f..492c629235 100644 --- a/testsuite/tests/indexed-types/should_compile/T7804.hs +++ b/testsuite/tests/indexed-types/should_compile/T7804.hs @@ -8,3 +8,15 @@ data Proxy a = P sDFMap :: (forall a. Proxy f -> Proxy a -> Proxy (F f a)) -> Int sDFMap _ = 3 + + +{- +flat cache + [G] F f_aqh aqj ~ fsk_aqp + [G] F f_aqg aqj ~ fsk_aqq + + [W] aqk : f_aqh[2] ~ f_aqg + [w] aql : fsk_aqp ~ fsk_aqq + + [G] F f_agh a_aqj ~ F f_aqg +-}
\ No newline at end of file diff --git a/testsuite/tests/indexed-types/should_compile/T9211.hs b/testsuite/tests/indexed-types/should_compile/T9211.hs new file mode 100644 index 0000000000..6ba0af4c56 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T9211.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +module T9211 where + +-- foo :: (forall f g. (Functor f) => f a -> f b) -> [a] -> [b] +foo :: (forall f g. (Functor f, g ~ f) => g a -> g b) -> [a] -> [b] +foo tr x = tr x + +t = foo (fmap not) [True] diff --git a/testsuite/tests/indexed-types/should_compile/T9747.hs b/testsuite/tests/indexed-types/should_compile/T9747.hs new file mode 100644 index 0000000000..05b4397630 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T9747.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, TypeFamilies, TypeOperators #-} +module T9747 where +import Data.List (intercalate) +import Data.Proxy +import GHC.Prim (Constraint) + +data HList :: [*] -> * where + Nil :: HList '[] + Cons :: a -> HList as -> HList (a ': as) + +type family HListAll (c :: * -> Constraint) (ts :: [*]) :: Constraint where + HListAll c '[] = () + HListAll c (t ': ts) = (c t, HListAll c ts) + +showHList :: HListAll Show ts => HList ts -> String +showHList = ("[" ++ ) . (++"]") . intercalate ", " . go + where + go :: HListAll Show ts => HList ts -> [String] + go Nil = [] + go (Cons x xs) = show x : go xs + +-- Things work okay up to this point +test :: String +test = showHList (Cons (2::Int) + (Cons (3.1 :: Float) + (Cons 'c' Nil))) + +type family ConFun (t :: *) :: * -> Constraint +data Tag +type instance ConFun Tag = Group + +class (Show a, Eq a, Ord a) => Group a + +-- This is notionally similar to showHList +bar :: HListAll (ConFun l) ts => Proxy l -> HList ts -> () +bar _ _ = () + +baz :: (ConFun l a, ConFun l b) => Proxy l -> HList [a,b] -> () +baz = bar diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T index ff45df2c83..fbd0b0e220 100644 --- a/testsuite/tests/indexed-types/should_compile/all.T +++ b/testsuite/tests/indexed-types/should_compile/all.T @@ -170,7 +170,7 @@ test('T4981-V2', normal, compile, ['']) test('T4981-V3', normal, compile, ['']) test('T5002', normal, compile, ['']) -test('PushedInAsGivens', normal, compile, ['']) +test('PushedInAsGivens', normal, compile_fail, ['']) # Superclass equalities test('T4338', normal, compile, ['']) @@ -247,3 +247,5 @@ test('T9085', normal, compile, ['']) test('T9316', normal, compile, ['']) test('red-black-delete', normal, compile, ['']) test('Sock', normal, compile, ['']) +test('T9211', normal, compile, ['']) +test('T9747', normal, compile, ['']) diff --git a/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.hs b/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.hs index f676c294a5..62798fad39 100644 --- a/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.hs +++ b/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.hs @@ -1,9 +1,9 @@ {-# LANGUAGE TypeFamilies, FunctionalDependencies, FlexibleContexts, GADTs, ScopedTypeVariables #-} -module ExtraTcsUntch where +module ExtraTcsUntch where -class C x y | x -> y where +class C x y | x -> y where op :: x -> y -> () instance C [a] [a] @@ -13,22 +13,24 @@ type family F a :: * h :: F Int -> () h = undefined -data TEx where - TEx :: a -> TEx +data TEx where + TEx :: a -> TEx -f x = +f x = let g1 :: forall b. b -> () g1 _ = h [x] + g2 z = case z of TEx y -> (h [[undefined]], op x [y]) + in (g1 '3', g2 undefined) -{- This example comes from Note [Extra TcS Untouchables] in TcSimplify. It demonstrates +{- This example comes from Note [Extra TcS Untouchables] in TcSimplify. It demonstrates why when floating equalities out of an implication constraint we must record the free variables of the equalities as untouchables. With GHC 7.4.1 this program gives a Core - Lint error because of an existential escaping. + Lint error because of an existential escaping. assuming x:beta @@ -39,16 +41,21 @@ f x = - + {- Assume x:beta - From g1 we get (forall b. F Int ~ [beta]) - From g2 we get (forall c. 0 => F Int ~ [[alpha]] /\ C beta [c]) - -Floating we get - F Int ~ [beta], F Int ~ [[alpha]], alpha ~ alpha', forall c. C beta [c] -= { alpha := alpha' } -= beta ~ [alpha'], F Int ~ [[alpha']], forall c. C beta [c] -= { beta := [alpha'] - F Int ~ [[alpha']], forall c. C [alpha'] [c] -= F Int ~ [[alpha']], forall c. (C [alpha'] [c], alpha' ~ c) + From g1 we get [W] (forall b. F Int ~ [beta]) + + From g2 we get [W] (forall c. 0 => F Int ~ [[alpha]] /\ C beta [c]) + (g2 is not generalised; the forall comes from the TEx pattern) + +approximateWC then gives the candidate constraints to quantify + F Int ~ [beta], F Int ~ [[alpha']] + +(alpha' is the promoted version of alpha) + +Now decide inferred sig for f :: F Int ~ [beta] => beta -> blah +since beta is mentioned in tau-type for f but alpha' is not + +Perhaps this is a stupid constraint to generalise over (we don't +generalise over (C Int). -}
\ No newline at end of file diff --git a/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.stderr b/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.stderr index 3e34058def..13f9911e6c 100644 --- a/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.stderr +++ b/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.stderr @@ -1,10 +1,16 @@ -ExtraTcsUntch.hs:24:53: - Could not deduce (C [t] [a]) arising from a use of ‘op’ - from the context (F Int ~ [[t]]) - bound by the inferred type of - f :: (F Int ~ [[t]]) => [t] -> ((), ((), ())) - at ExtraTcsUntch.hs:(21,1)-(25,29) - In the expression: op x [y] +ExtraTcsUntch.hs:23:18: + Couldn't match expected type ‘F Int’ with actual type ‘[t]’ + Relevant bindings include + x :: t (bound at ExtraTcsUntch.hs:21:3) + f :: t -> ((), ((), ())) (bound at ExtraTcsUntch.hs:21:1) + In the first argument of ‘h’, namely ‘[x]’ + In the expression: h [x] + In an equation for ‘g1’: g1 _ = h [x] + +ExtraTcsUntch.hs:25:38: + Couldn't match expected type ‘F Int’ with actual type ‘[[t0]]’ + The type variable ‘t0’ is ambiguous + In the first argument of ‘h’, namely ‘[[undefined]]’ + In the expression: h [[undefined]] In the expression: (h [[undefined]], op x [y]) - In a case alternative: TEx y -> (h [[undefined]], op x [y]) diff --git a/testsuite/tests/indexed-types/should_fail/GADTwrong1.hs b/testsuite/tests/indexed-types/should_fail/GADTwrong1.hs index 7295090439..1af3516746 100644 --- a/testsuite/tests/indexed-types/should_fail/GADTwrong1.hs +++ b/testsuite/tests/indexed-types/should_fail/GADTwrong1.hs @@ -5,8 +5,34 @@ module ShouldFail where type family Const a type instance Const a = () -data T a where T :: a -> T (Const a) +data T a where T :: c -> T (Const c) coerce :: forall a b . a -> b coerce x = case T x :: T (Const b) of - T y -> y + T y -> y + +{- + T :: forall a. forall c. (a ~ Const c) => c -> T a + + a ~ gamma -- Instantiate T with a=alpha, c=gamma + alpha ~ Const b -- Result of (T x) + alpha ~ Const gamma -- Constraint from (T x) + + y::c + forall c. (Const b ~ Const c) => c ~ b + +==> + Const b ~ Const a + +------------ + +case e of + T y -> y + + e :: T alpha + + Patterns + forall c. (alpha ~ Const c) => c ~ b + alpha ~ Const b + +-}
\ No newline at end of file diff --git a/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr b/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr index dc94b9a7c3..c49049b400 100644 --- a/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr +++ b/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr @@ -1,20 +1,15 @@ -GADTwrong1.hs:12:19: - Could not deduce (a1 ~ b) - from the context (() ~ Const a1) - bound by a pattern with constructor - T :: forall a. a -> T (Const a), - in a case alternative - at GADTwrong1.hs:12:12-14 - ‘a1’ is a rigid type variable bound by - a pattern with constructor - T :: forall a. a -> T (Const a), - in a case alternative - at GADTwrong1.hs:12:12 +GADTwrong1.hs:12:21: + Couldn't match expected type ‘b’ with actual type ‘c’ + ‘c’ is a rigid type variable bound by + a pattern with constructor + T :: forall c. c -> T (Const c), + in a case alternative + at GADTwrong1.hs:12:14 ‘b’ is a rigid type variable bound by the type signature for coerce :: a -> b at GADTwrong1.hs:10:20 Relevant bindings include - y :: a1 (bound at GADTwrong1.hs:12:14) + y :: c (bound at GADTwrong1.hs:12:16) coerce :: a -> b (bound at GADTwrong1.hs:11:1) In the expression: y In a case alternative: T y -> y diff --git a/testsuite/tests/indexed-types/should_fail/NoMatchErr.stderr b/testsuite/tests/indexed-types/should_fail/NoMatchErr.stderr index d3193d5f30..f825fd2af6 100644 --- a/testsuite/tests/indexed-types/should_fail/NoMatchErr.stderr +++ b/testsuite/tests/indexed-types/should_fail/NoMatchErr.stderr @@ -1,9 +1,6 @@ NoMatchErr.hs:19:7: - Could not deduce (Memo d0 ~ Memo d) - from the context (Fun d) - bound by the type signature for f :: Fun d => Memo d a -> Memo d a - at NoMatchErr.hs:19:7-37 + Couldn't match type ‘Memo d’ with ‘Memo d0’ NB: ‘Memo’ is a type function, and may not be injective The type variable ‘d0’ is ambiguous Expected type: Memo d a -> Memo d a diff --git a/testsuite/tests/indexed-types/should_fail/Overlap9.stderr b/testsuite/tests/indexed-types/should_fail/Overlap9.stderr index 92cf6202de..9dd542f4c8 100644 --- a/testsuite/tests/indexed-types/should_fail/Overlap9.stderr +++ b/testsuite/tests/indexed-types/should_fail/Overlap9.stderr @@ -1,9 +1,6 @@ Overlap9.hs:10:7: - Could not deduce (F a ~ Int) - from the context (Show a) - bound by the type signature for g :: Show a => a -> F a - at Overlap9.hs:9:6-23 + Couldn't match expected type ‘F a’ with actual type ‘Int’ Relevant bindings include x :: a (bound at Overlap9.hs:10:3) g :: a -> F a (bound at Overlap9.hs:10:1) diff --git a/testsuite/tests/indexed-types/should_fail/T1897b.stderr b/testsuite/tests/indexed-types/should_fail/T1897b.stderr index 785f21ad89..936aa26924 100644 --- a/testsuite/tests/indexed-types/should_fail/T1897b.stderr +++ b/testsuite/tests/indexed-types/should_fail/T1897b.stderr @@ -1,16 +1,12 @@ T1897b.hs:16:1: - Could not deduce (Depend a0 ~ Depend a) - from the context (Bug a, Foldable t) - bound by the inferred type for ‘isValid’: - (Bug a, Foldable t) => t (Depend a) -> Bool - at T1897b.hs:16:1-41 + Couldn't match type ‘Depend a’ with ‘Depend a0’ NB: ‘Depend’ is a type function, and may not be injective The type variable ‘a0’ is ambiguous Expected type: t (Depend a) -> Bool Actual type: t (Depend a0) -> Bool When checking that ‘isValid’ has the inferred type isValid :: forall a (t :: * -> *). - (Bug a, Foldable t) => + (Foldable t, Bug a) => t (Depend a) -> Bool Probable cause: the inferred type is ambiguous diff --git a/testsuite/tests/indexed-types/should_fail/T1900.stderr b/testsuite/tests/indexed-types/should_fail/T1900.stderr index d44b4ed210..73fe38108a 100644 --- a/testsuite/tests/indexed-types/should_fail/T1900.stderr +++ b/testsuite/tests/indexed-types/should_fail/T1900.stderr @@ -1,9 +1,6 @@ T1900.hs:13:10: - Could not deduce (Depend s0 ~ Depend s) - from the context (Bug s) - bound by the type signature for check :: Bug s => Depend s -> Bool - at T1900.hs:13:10-36 + Couldn't match type ‘Depend s0’ with ‘Depend s’ NB: ‘Depend’ is a type function, and may not be injective The type variable ‘s0’ is ambiguous Expected type: Depend s -> Bool diff --git a/testsuite/tests/indexed-types/should_fail/T2544.hs b/testsuite/tests/indexed-types/should_fail/T2544.hs index 22f3995286..3653a42317 100644 --- a/testsuite/tests/indexed-types/should_fail/T2544.hs +++ b/testsuite/tests/indexed-types/should_fail/T2544.hs @@ -12,4 +12,17 @@ data BiApp a b c = BiApp (a c) (b c) instance (Ix l, Ix r) => Ix (l :|: r) where
type IxMap (l :|: r) = BiApp (IxMap l) (IxMap r)
- empty = BiApp empty empty
\ No newline at end of file + empty = BiApp empty empty
+
+-- [W] w1: a c ~ IxMap ii1 [Int] (from first 'empty')
+-- [W] w2: b c ~ IxMap ii2 [Int] (from second 'empty')
+-- [W] w3: BiApp a b c ~ IxMap (l :|: r) [Int] (from call of BiApp
+-- ~ BiApp (IxMap l) (IxMap r) [Int]
+
+-- If we process w3 first, we'll rewrite it with w1, w2
+-- yielding two constraints (Ix io ~ IxMap l, Ix i1 ~ IxMap r)
+-- both with location of w3. Then we report just one of them,
+-- because we suppress multiple errors from the same location
+--
+-- But if we process w1,w2 first, we'll get the same constraints
+-- but this time with different locations.
diff --git a/testsuite/tests/indexed-types/should_fail/T2544.stderr b/testsuite/tests/indexed-types/should_fail/T2544.stderr index 244580f922..256fa30522 100644 --- a/testsuite/tests/indexed-types/should_fail/T2544.stderr +++ b/testsuite/tests/indexed-types/should_fail/T2544.stderr @@ -1,8 +1,6 @@ T2544.hs:15:18: - Could not deduce (IxMap i0 ~ IxMap l) - from the context (Ix l, Ix r) - bound by the instance declaration at T2544.hs:13:10-37 + Couldn't match type ‘IxMap i0’ with ‘IxMap l’ NB: ‘IxMap’ is a type function, and may not be injective The type variable ‘i0’ is ambiguous Expected type: IxMap l [Int] @@ -13,9 +11,7 @@ T2544.hs:15:18: In the expression: BiApp empty empty T2544.hs:15:24: - Could not deduce (IxMap i1 ~ IxMap r) - from the context (Ix l, Ix r) - bound by the instance declaration at T2544.hs:13:10-37 + Couldn't match type ‘IxMap i1’ with ‘IxMap r’ NB: ‘IxMap’ is a type function, and may not be injective The type variable ‘i1’ is ambiguous Expected type: IxMap r [Int] diff --git a/testsuite/tests/indexed-types/should_fail/T2627b.hs b/testsuite/tests/indexed-types/should_fail/T2627b.hs index 13dbd9cb26..0e1f103786 100644 --- a/testsuite/tests/indexed-types/should_fail/T2627b.hs +++ b/testsuite/tests/indexed-types/should_fail/T2627b.hs @@ -12,9 +12,15 @@ type instance Dual (R a b) = W a (Dual b) type instance Dual (W a b) = R a (Dual b) data Comm a where - Rd :: (a -> Comm b) -> Comm (R a b) - Wr :: a -> Comm b -> Comm (W a b) + Rd :: (c -> Comm d) -> Comm (R c d) + Wr :: e -> Comm f -> Comm (W e f) Fin :: Int -> Comm Z conn :: (Dual a ~ b, Dual b ~ a) => Comm a -> Comm b -> (Int, Int) conn (Rd k) (Wr a r) = conn undefined undefined + +{- + [G] a ~ R c d + [G] b ~ W e f + [W] Dual alpha ~ beta, [W] Dual beta ~ alpha +-}
\ No newline at end of file diff --git a/testsuite/tests/indexed-types/should_fail/T2664.hs b/testsuite/tests/indexed-types/should_fail/T2664.hs index f8fad88192..bda1adfa42 100644 --- a/testsuite/tests/indexed-types/should_fail/T2664.hs +++ b/testsuite/tests/indexed-types/should_fail/T2664.hs @@ -29,3 +29,20 @@ instance (Connect a, Connect b) => Connect (a :*: b) where -- type error leads to stack overflow (even without UndecidableInstances!) return (O $ takeMVar v, E (pchoose Right v newPChan) (pchoose Left v newPChan)) + +{- The last line gives rise to: + + [G] (a :*: b) ~ Dual c + [G] c ~ Dual (a :*: b) +--> + [G] c ~ Dual a :+: Dual b + + [W] PChan c ~ PChan (Dual b :+: Dual a) +--> decompose + [W] c ~ Dual b :+: Dual a +--> subst + [W] Dual a :+: Dual b ~ Dual b :+: Dual a +--> decompose + [W] Dual a ~ Dual b + [W] Dual b ~ Dual a +-}
\ No newline at end of file diff --git a/testsuite/tests/indexed-types/should_fail/T2664.stderr b/testsuite/tests/indexed-types/should_fail/T2664.stderr index 4104eb58c4..402d12b753 100644 --- a/testsuite/tests/indexed-types/should_fail/T2664.stderr +++ b/testsuite/tests/indexed-types/should_fail/T2664.stderr @@ -1,23 +1,19 @@ -T2664.hs:31:52: - Could not deduce (b ~ a) - from the context (Connect a, Connect b) - bound by the instance declaration at T2664.hs:22:10-52 - or from ((a :*: b) ~ Dual c, c ~ Dual (a :*: b)) +T2664.hs:31:33: + Could not deduce (Dual b ~ Dual a) + from the context ((a :*: b) ~ Dual c, c ~ Dual (a :*: b)) bound by the type signature for newPChan :: ((a :*: b) ~ Dual c, c ~ Dual (a :*: b)) => IO (PChan (a :*: b), PChan c) at T2664.hs:23:5-12 - ‘b’ is a rigid type variable bound by - the instance declaration at T2664.hs:22:10 - ‘a’ is a rigid type variable bound by - the instance declaration at T2664.hs:22:10 - Expected type: Dual (Dual a) - Actual type: b + NB: ‘Dual’ is a type function, and may not be injective + Expected type: PChan c + Actual type: PChan (Dual b :+: Dual a) Relevant bindings include v :: MVar (Either (PChan a) (PChan b)) (bound at T2664.hs:24:9) newPChan :: IO (PChan (a :*: b), PChan c) (bound at T2664.hs:23:5) - In the third argument of ‘pchoose’, namely ‘newPChan’ - In the first argument of ‘E’, namely ‘(pchoose Right v newPChan)’ In the expression: E (pchoose Right v newPChan) (pchoose Left v newPChan) + In the first argument of ‘return’, namely + ‘(O $ takeMVar v, + E (pchoose Right v newPChan) (pchoose Left v newPChan))’ diff --git a/testsuite/tests/indexed-types/should_fail/T2693.stderr b/testsuite/tests/indexed-types/should_fail/T2693.stderr index b613ab7ab5..0c6ea152a7 100644 --- a/testsuite/tests/indexed-types/should_fail/T2693.stderr +++ b/testsuite/tests/indexed-types/should_fail/T2693.stderr @@ -16,16 +16,16 @@ T2693.hs:11:7: return () }
T2693.hs:19:15:
- Couldn't match expected type ‘(a2, b0)’ with actual type ‘TFn a3’
- The type variables ‘a2’, ‘b0’, ‘a3’ are ambiguous
- Relevant bindings include n :: a2 (bound at T2693.hs:19:7)
+ Couldn't match expected type ‘(a5, b0)’ with actual type ‘TFn a2’
+ The type variables ‘b0’, ‘a2’, ‘a5’ are ambiguous
+ Relevant bindings include n :: a5 (bound at T2693.hs:19:7)
In the first argument of ‘fst’, namely ‘x’
In the first argument of ‘(+)’, namely ‘fst x’
T2693.hs:19:23:
- Couldn't match expected type ‘(a4, a2)’ with actual type ‘TFn a5’
- The type variables ‘a2’, ‘a4’, ‘a5’ are ambiguous
- Relevant bindings include n :: a2 (bound at T2693.hs:19:7)
+ Couldn't match expected type ‘(a3, a5)’ with actual type ‘TFn a4’
+ The type variables ‘a3’, ‘a4’, ‘a5’ are ambiguous
+ Relevant bindings include n :: a5 (bound at T2693.hs:19:7)
In the first argument of ‘snd’, namely ‘x’
In the second argument of ‘(+)’, namely ‘snd x’
diff --git a/testsuite/tests/indexed-types/should_fail/T4093a.hs b/testsuite/tests/indexed-types/should_fail/T4093a.hs index 06168f577e..746f996d57 100644 --- a/testsuite/tests/indexed-types/should_fail/T4093a.hs +++ b/testsuite/tests/indexed-types/should_fail/T4093a.hs @@ -6,3 +6,34 @@ type instance Foo () = Maybe () hang :: (Foo e ~ Maybe e) => Foo e
hang = Just ()
+
+
+{- Ambiguity check
+
+ [G] Foo e ~ Maybe e
+ [W] Foo e ~ Foo ee
+ [W] Foo ee ~ Maybe ee)
+---
+ [G] Foo e ~ fsk
+ [G] fsk ~ Maybe e
+
+ [W] Foo e ~ fmv1
+ [W] Foo ee ~ fmv2
+ [W] fmv1 ~ fmv2
+ [W] fmv2 ~ Maybe ee
+
+---> fmv1 := fsk
+ [W] Foo ee ~ fmv2
+ [W] fsk ~ fmv2
+ [W] fmv2 ~ Maybe ee
+
+--->
+ [W] Foo ee ~ fmv2
+ [W] fmv2 ~ Maybe e
+ [W] fmv2 ~ Maybe ee
+
+Now the question is whether we get a derived equality e ~ ee. Currently
+we don't, but we easily could. But then we'd need to be careful not to
+report insoluble Int ~ Bool if we had
+ F a ~ Int, F a ~ Bool
+-}
\ No newline at end of file diff --git a/testsuite/tests/indexed-types/should_fail/T4093a.stderr b/testsuite/tests/indexed-types/should_fail/T4093a.stderr index 90b8a592f6..076041be32 100644 --- a/testsuite/tests/indexed-types/should_fail/T4093a.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4093a.stderr @@ -1,14 +1,11 @@ -T4093a.hs:8:8: - Could not deduce (e ~ ()) +T4093a.hs:7:9: + Could not deduce (Foo e0 ~ Maybe e0) from the context (Foo e ~ Maybe e) bound by the type signature for hang :: (Foo e ~ Maybe e) => Foo e at T4093a.hs:7:9-34 - ‘e’ is a rigid type variable bound by - the type signature for hang :: (Foo e ~ Maybe e) => Foo e - at T4093a.hs:7:9 - Expected type: Foo e - Actual type: Maybe () - Relevant bindings include hang :: Foo e (bound at T4093a.hs:8:1) - In the expression: Just () - In an equation for ‘hang’: hang = Just () + The type variable ‘e0’ is ambiguous + In the ambiguity check for: forall e. (Foo e ~ Maybe e) => Foo e + To defer the ambiguity check to use sites, enable AllowAmbiguousTypes + In the type signature for ‘hang’: + hang :: (Foo e ~ Maybe e) => Foo e diff --git a/testsuite/tests/indexed-types/should_fail/T4174.stderr b/testsuite/tests/indexed-types/should_fail/T4174.stderr index 19d3e8d3e0..6b5ada2932 100644 --- a/testsuite/tests/indexed-types/should_fail/T4174.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4174.stderr @@ -1,7 +1,28 @@ T4174.hs:42:12: - Couldn't match type ‘False’ with ‘True’ - Expected type: True - Actual type: GHCVersion (WayOf m) :>=: GHC6'10 Minor1 + Couldn't match type ‘a’ with ‘SmStep’ + ‘a’ is a rigid type variable bound by + the type signature for + testcase :: Monad m => m (Field (Way (GHC6'8 minor) n t p) a b) + at T4174.hs:41:13 + Expected type: m (Field (Way (GHC6'8 minor) n t p) a b) + Actual type: m (Field (WayOf m) SmStep RtsSpinLock) + Relevant bindings include + testcase :: m (Field (Way (GHC6'8 minor) n t p) a b) + (bound at T4174.hs:42:1) + In the expression: sync_large_objects + In an equation for ‘testcase’: testcase = sync_large_objects + +T4174.hs:42:12: + Couldn't match type ‘b’ with ‘RtsSpinLock’ + ‘b’ is a rigid type variable bound by + the type signature for + testcase :: Monad m => m (Field (Way (GHC6'8 minor) n t p) a b) + at T4174.hs:41:13 + Expected type: m (Field (Way (GHC6'8 minor) n t p) a b) + Actual type: m (Field (WayOf m) SmStep RtsSpinLock) + Relevant bindings include + testcase :: m (Field (Way (GHC6'8 minor) n t p) a b) + (bound at T4174.hs:42:1) In the expression: sync_large_objects In an equation for ‘testcase’: testcase = sync_large_objects diff --git a/testsuite/tests/indexed-types/should_fail/T4179.stderr b/testsuite/tests/indexed-types/should_fail/T4179.stderr index 40fb84d83a..f9bb6bb2ad 100644 --- a/testsuite/tests/indexed-types/should_fail/T4179.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4179.stderr @@ -1,13 +1,8 @@ T4179.hs:26:16: - Could not deduce (A3 (x (A2 (FCon x) -> A3 (FCon x))) - ~ A3 (FCon x)) - from the context (Functor x, DoC (FCon x)) - bound by the type signature for - fCon :: (Functor x, DoC (FCon x)) => - Con x -> A2 (FCon x) -> A3 (FCon x) - at T4179.hs:25:9-72 - NB: ‘A3’ is a type function, and may not be injective + Couldn't match type ‘A2 (x (A2 (FCon x) -> A3 (FCon x)))’ + with ‘A2 (FCon x)’ + NB: ‘A2’ is a type function, and may not be injective Expected type: x (A2 (FCon x) -> A3 (FCon x)) -> A2 (FCon x) -> A3 (FCon x) Actual type: x (A2 (FCon x) -> A3 (FCon x)) diff --git a/testsuite/tests/indexed-types/should_fail/T4272.stderr b/testsuite/tests/indexed-types/should_fail/T4272.stderr index 7c98377ed7..1000b9a3f1 100644 --- a/testsuite/tests/indexed-types/should_fail/T4272.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4272.stderr @@ -1,10 +1,6 @@ T4272.hs:15:26: - Could not deduce (a ~ TermFamily a a) - from the context (TermLike a) - bound by the type signature for - laws :: TermLike a => TermFamily a a -> b - at T4272.hs:14:9-53 + Couldn't match type ‘a’ with ‘TermFamily a a’ ‘a’ is a rigid type variable bound by the type signature for laws :: TermLike a => TermFamily a a -> b at T4272.hs:14:16 diff --git a/testsuite/tests/indexed-types/should_fail/T5439.stderr b/testsuite/tests/indexed-types/should_fail/T5439.stderr index 19517cbf57..3bffb4fc6c 100644 --- a/testsuite/tests/indexed-types/should_fail/T5439.stderr +++ b/testsuite/tests/indexed-types/should_fail/T5439.stderr @@ -1,26 +1,25 @@ - -T5439.hs:82:28: - Couldn't match type ‘Attempt (HHead (HDrop n0 l0)) - -> Attempt (HElemOf l0)’ - with ‘Attempt (WaitOpResult (WaitOps rs))’ - Expected type: f (Attempt (HNth n0 l0) -> Attempt (HElemOf l0)) - Actual type: f (Attempt (WaitOpResult (WaitOps rs))) - Relevant bindings include - register :: Bool -> Peano n -> WaitOps (HDrop n rs) -> IO Bool - (bound at T5439.hs:64:9) - ev :: f (Attempt (WaitOpResult (WaitOps rs))) - (bound at T5439.hs:61:22) - ops :: WaitOps rs (bound at T5439.hs:61:18) - registerWaitOp :: WaitOps rs - -> f (Attempt (WaitOpResult (WaitOps rs))) -> IO Bool - (bound at T5439.hs:61:3) - In the first argument of ‘complete’, namely ‘ev’ - In the expression: complete ev - -T5439.hs:82:39: - Couldn't match expected type ‘Peano n0’ - with actual type ‘Attempt α0’ - In the second argument of ‘($)’, namely - ‘Failure (e :: SomeException)’ - In the second argument of ‘($)’, namely - ‘inj $ Failure (e :: SomeException)’ +
+T5439.hs:82:28:
+ Couldn't match type ‘Attempt (HNth n0 l0) -> Attempt (HElemOf l0)’
+ with ‘Attempt (WaitOpResult (WaitOps rs))’
+ Expected type: f (Attempt (HNth n0 l0) -> Attempt (HElemOf l0))
+ Actual type: f (Attempt (WaitOpResult (WaitOps rs)))
+ Relevant bindings include
+ register :: Bool -> Peano n -> WaitOps (HDrop n rs) -> IO Bool
+ (bound at T5439.hs:64:9)
+ ev :: f (Attempt (WaitOpResult (WaitOps rs)))
+ (bound at T5439.hs:61:22)
+ ops :: WaitOps rs (bound at T5439.hs:61:18)
+ registerWaitOp :: WaitOps rs
+ -> f (Attempt (WaitOpResult (WaitOps rs))) -> IO Bool
+ (bound at T5439.hs:61:3)
+ In the first argument of ‘complete’, namely ‘ev’
+ In the expression: complete ev
+
+T5439.hs:82:39:
+ Couldn't match expected type ‘Peano n0’
+ with actual type ‘Attempt α0’
+ In the second argument of ‘($)’, namely
+ ‘Failure (e :: SomeException)’
+ In the second argument of ‘($)’, namely
+ ‘inj $ Failure (e :: SomeException)’
diff --git a/testsuite/tests/indexed-types/should_fail/T5934.stderr b/testsuite/tests/indexed-types/should_fail/T5934.stderr index 67a468057c..8460105c2f 100644 --- a/testsuite/tests/indexed-types/should_fail/T5934.stderr +++ b/testsuite/tests/indexed-types/should_fail/T5934.stderr @@ -1,8 +1,7 @@ -
-T5934.hs:12:7:
- Couldn't match type ‘Integer’
- with ‘(forall s. Gen (PrimState (ST s))) -> Int’
- Expected type: Integer -> (forall s. GenST s) -> Int
- Actual type: Integer -> Integer
- In the expression: 0
- In an equation for ‘run’: run = 0
+ +T5934.hs:12:7: + Couldn't match type ‘Integer’ with ‘(forall s. GenST s) -> Int’ + Expected type: Integer -> (forall s. GenST s) -> Int + Actual type: Integer -> Integer + In the expression: 0 + In an equation for ‘run’: run = 0 diff --git a/testsuite/tests/indexed-types/should_fail/T7010.stderr b/testsuite/tests/indexed-types/should_fail/T7010.stderr index 16891fb6b0..776164ce4b 100644 --- a/testsuite/tests/indexed-types/should_fail/T7010.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7010.stderr @@ -1,6 +1,6 @@ T7010.hs:53:27: - Couldn't match type ‘Serial (IO Float)’ with ‘IO Float’ + Couldn't match type ‘IO Float’ with ‘Serial (ValueTuple Float)’ Expected type: (Float, ValueTuple Vector) Actual type: (Float, ValueTuple Float) In the first argument of ‘withArgs’, namely ‘plug’ diff --git a/testsuite/tests/indexed-types/should_fail/T7729.stderr b/testsuite/tests/indexed-types/should_fail/T7729.stderr index c8814a412d..1e93e4017c 100644 --- a/testsuite/tests/indexed-types/should_fail/T7729.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7729.stderr @@ -1,16 +1,12 @@ - -T7729.hs:36:14: - Could not deduce (BasePrimMonad (Rand m) - ~ t0 (BasePrimMonad (Rand m))) - from the context (PrimMonad (BasePrimMonad (Rand m)), - Monad (Rand m), - MonadPrim m) - bound by the instance declaration at T7729.hs:34:10-42 - The type variable ‘t0’ is ambiguous - Expected type: t0 (BasePrimMonad (Rand m)) a -> Rand m a - Actual type: BasePrimMonad (Rand m) a -> Rand m a - Relevant bindings include - liftPrim :: BasePrimMonad (Rand m) a -> Rand m a - (bound at T7729.hs:36:3) - In the first argument of ‘(.)’, namely ‘liftPrim’ - In the expression: liftPrim . lift +
+T7729.hs:36:14:
+ Couldn't match type ‘BasePrimMonad (Rand m)’
+ with ‘t0 (BasePrimMonad (Rand m))’
+ The type variable ‘t0’ is ambiguous
+ Expected type: t0 (BasePrimMonad (Rand m)) a -> Rand m a
+ Actual type: BasePrimMonad (Rand m) a -> Rand m a
+ Relevant bindings include
+ liftPrim :: BasePrimMonad (Rand m) a -> Rand m a
+ (bound at T7729.hs:36:3)
+ In the first argument of ‘(.)’, namely ‘liftPrim’
+ In the expression: liftPrim . lift
diff --git a/testsuite/tests/indexed-types/should_fail/T7729a.hs b/testsuite/tests/indexed-types/should_fail/T7729a.hs index ea36e32bd6..4e464d67f3 100644 --- a/testsuite/tests/indexed-types/should_fail/T7729a.hs +++ b/testsuite/tests/indexed-types/should_fail/T7729a.hs @@ -34,3 +34,44 @@ instance MonadTrans Rand where instance MonadPrim m => MonadPrim (Rand m) where type BasePrimMonad (Rand m) = BasePrimMonad m liftPrim x = liftPrim (lift x) -- This line changed from T7729 + +{- + liftPrim :: (MonadPrim m) => BasePrimMonad m a -> m a + lift :: MonadTrans t, Monad m => m a -> t m a + + sig of liftPrim :: BasePrimMonad (Rand m) a -> Rand m a + = BasePrimMonad m a -> Rand m a + + x :: BasePrimMonad (Rand m) a + lift @ t=tt @ m=m1 + liftPrim @ m=m2 @ a=aa + + forall m. (Monad m) => BasePrimMonad (Rand m) a ~ m1 a -- x arg of lift + + tt m1 a -- Result of lift + ~ + BasePrimMonad m2 a -- Arg of liftPrim + + Rand m a -- expected type of RHS + ~ + m2 a -- Result of liftPrim + m = m_and + m1 = m_aql + m2 = m_aqf + tt = t_aqj + +----> + m2 := Rand m + +a) BasePrimMonad (Rand m) ~ m1 +b) tt m1 ~ BasePrimMonad (Rand m) + +---> process (b) first + CFunEqCan BasePrimMonad (Ramd m) ~ s_atH + s_atH ~ tt m1 + + +---> now process (a) + m1 ~ s_atH ~ tt m1 -- An obscure occurs check +-} + diff --git a/testsuite/tests/indexed-types/should_fail/T7729a.stderr b/testsuite/tests/indexed-types/should_fail/T7729a.stderr index 907eb1d3b1..93142006ed 100644 --- a/testsuite/tests/indexed-types/should_fail/T7729a.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7729a.stderr @@ -1,11 +1,7 @@ T7729a.hs:36:26: - Could not deduce (BasePrimMonad (Rand m) - ~ t0 (BasePrimMonad (Rand m))) - from the context (PrimMonad (BasePrimMonad (Rand m)), - Monad (Rand m), - MonadPrim m) - bound by the instance declaration at T7729a.hs:34:10-42 + Couldn't match type ‘BasePrimMonad (Rand m)’ + with ‘t0 (BasePrimMonad (Rand m))’ The type variable ‘t0’ is ambiguous Expected type: BasePrimMonad (Rand m) a Actual type: t0 (BasePrimMonad (Rand m)) a diff --git a/testsuite/tests/indexed-types/should_fail/T7786.hs b/testsuite/tests/indexed-types/should_fail/T7786.hs index 72cf061632..839a1fb83d 100644 --- a/testsuite/tests/indexed-types/should_fail/T7786.hs +++ b/testsuite/tests/indexed-types/should_fail/T7786.hs @@ -17,7 +17,7 @@ data KeySegment = Numic Nat | Symic Symbol data instance Sing (n :: KeySegment) where Numic' :: Sing n -> Sing (Numic n) - Symic' :: Sing s -> Sing (Symic s) + Symic' :: Sing ss -> Sing (Symic ss) data instance Sing (k :: [KeySegment]) where Root' :: Sing ('[] :: [KeySegment]) diff --git a/testsuite/tests/indexed-types/should_fail/T8129.stdout b/testsuite/tests/indexed-types/should_fail/T8129.stdout index 748ffca497..bd543d6d84 100644 --- a/testsuite/tests/indexed-types/should_fail/T8129.stdout +++ b/testsuite/tests/indexed-types/should_fail/T8129.stdout @@ -1,2 +1,2 @@ - Could not deduce (C x0 y0) - Could not deduce (C x0 y0) + Could not deduce (C x0 (F x0))
+ Could not deduce (C x0 (F x0))
diff --git a/testsuite/tests/indexed-types/should_fail/T8227.hs b/testsuite/tests/indexed-types/should_fail/T8227.hs index 69471dba66..97e8ef5855 100644 --- a/testsuite/tests/indexed-types/should_fail/T8227.hs +++ b/testsuite/tests/indexed-types/should_fail/T8227.hs @@ -21,15 +21,20 @@ Scalar (V a) ~ Scalar (V p0) Scalar (V a) ~ p0 Scalar (V a) ~ Scalar (V p0) -> Scalar (V p0) - -Scalar (V a) ~ t0 -Scalar (V p0) ~ t0 -Scalar (V a) ~ p0 -Scalar (V a) ~ t0 -> t0 - -Scalar (V a) ~ t0 -Scalar (V t0) ~ t0 -Scalar (V a) ~ t0 -> t0 +---> +Scalar (V a) ~ fuv0 +Scalar (V p0) ~ fuv1 +fuv0 ~ fuv1 +fuv0 ~ p0 +fuv0 ~ fuv1 -> fuv1 + +---> p0 := fuv0 + +Scalar (V a) ~ fuv0 (CFunEqCan) +Scalar (V fuv0) ~ fuv1 (CFunEqCan) +fuv0 ~ fuv1 +p0 ~ fuv0 +fuv0 ~ fuv1 -> fuv1 -} diff --git a/testsuite/tests/indexed-types/should_fail/T8227.stderr b/testsuite/tests/indexed-types/should_fail/T8227.stderr index 6bea6194b2..f09d468a75 100644 --- a/testsuite/tests/indexed-types/should_fail/T8227.stderr +++ b/testsuite/tests/indexed-types/should_fail/T8227.stderr @@ -1,9 +1,21 @@ +T8227.hs:16:27: + Couldn't match expected type ‘Scalar (V a)’ + with actual type ‘Scalar (V (Scalar (V a))) + -> Scalar (V (Scalar (V a)))’ + Relevant bindings include + seg :: a (bound at T8227.hs:16:21) + eps :: Scalar (V a) (bound at T8227.hs:16:17) + absoluteToParam :: Scalar (V a) -> a -> Scalar (V a) + (bound at T8227.hs:16:1) + In the expression: arcLengthToParam eps eps + In an equation for ‘absoluteToParam’: + absoluteToParam eps seg = arcLengthToParam eps eps + T8227.hs:16:44: - Couldn't match type ‘Scalar (V a)’ - with ‘Scalar (V a) -> Scalar (V a)’ - Expected type: Scalar (V (Scalar (V a))) - Actual type: Scalar (V a) + Couldn't match expected type ‘Scalar (V (Scalar (V a)))’ + with actual type ‘Scalar (V a)’ + NB: ‘Scalar’ is a type function, and may not be injective Relevant bindings include seg :: a (bound at T8227.hs:16:21) eps :: Scalar (V a) (bound at T8227.hs:16:17) diff --git a/testsuite/tests/indexed-types/should_fail/T8518.stderr b/testsuite/tests/indexed-types/should_fail/T8518.stderr index d7c20105e1..cb56e21999 100644 --- a/testsuite/tests/indexed-types/should_fail/T8518.stderr +++ b/testsuite/tests/indexed-types/should_fail/T8518.stderr @@ -1,35 +1,13 @@ - -T8518.hs:14:18: - Could not deduce (F c ~ Maybe (F c)) - from the context (Continuation c) - bound by the type signature for - callCont :: Continuation c => c -> Z c -> B c -> Maybe (F c) - at T8518.hs:13:13-64 - Relevant bindings include - b :: B c (bound at T8518.hs:14:14) - z :: Z c (bound at T8518.hs:14:12) - c :: c (bound at T8518.hs:14:10) - callCont :: c -> Z c -> B c -> Maybe (F c) (bound at T8518.hs:14:1) - In the expression: rpt (4 :: Int) c z b - In an equation for ‘callCont’: - callCont c z b - = rpt (4 :: Int) c z b - where - rpt 0 c' z' b' = fromJust (fst <$> (continue c' z' b')) - rpt i c' z' b' = let ... in rpt (i - 1) c'' - -T8518.hs:17:78: - Could not deduce (F a1 ~ (Z a1 -> B a1 -> F a1)) - from the context (Continuation c) - bound by the type signature for - callCont :: Continuation c => c -> Z c -> B c -> Maybe (F c) - at T8518.hs:13:13-64 - Relevant bindings include - c'' :: a1 (bound at T8518.hs:17:30) - b' :: B a1 (bound at T8518.hs:17:21) - z' :: Z a1 (bound at T8518.hs:17:18) - c' :: a1 (bound at T8518.hs:17:15) - rpt :: a -> a1 -> Z a1 -> B a1 -> F a1 (bound at T8518.hs:16:9) - In the expression: rpt (i - 1) c'' - In the expression: - let c'' = fromJust (snd <$> (continue c' z' b')) in rpt (i - 1) c'' +
+T8518.hs:17:78:
+ Couldn't match expected type ‘F a1’
+ with actual type ‘Z a1 -> B a1 -> F a1’
+ Relevant bindings include
+ c'' :: a1 (bound at T8518.hs:17:30)
+ b' :: B a1 (bound at T8518.hs:17:21)
+ z' :: Z a1 (bound at T8518.hs:17:18)
+ c' :: a1 (bound at T8518.hs:17:15)
+ rpt :: a -> a1 -> Z a1 -> B a1 -> F a1 (bound at T8518.hs:16:9)
+ In the expression: rpt (i - 1) c''
+ In the expression:
+ let c'' = fromJust (snd <$> (continue c' z' b')) in rpt (i - 1) c''
diff --git a/testsuite/tests/indexed-types/should_fail/T9036.stderr b/testsuite/tests/indexed-types/should_fail/T9036.stderr index 2df53c712c..3a6e38ee34 100644 --- a/testsuite/tests/indexed-types/should_fail/T9036.stderr +++ b/testsuite/tests/indexed-types/should_fail/T9036.stderr @@ -1,7 +1,7 @@ T9036.hs:17:17: - Couldn't match type ‘GetMonad t0’ with ‘GetMonad t’ - NB: ‘GetMonad’ is a type function, and may not be injective + Couldn't match type ‘Curried t [t]’ with ‘Curried t0 [t0]’ + NB: ‘Curried’ is a type function, and may not be injective The type variable ‘t0’ is ambiguous Expected type: Maybe (GetMonad t after) -> Curried t [t] Actual type: Maybe (GetMonad t0 after) -> Curried t0 [t0] diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout index 9e5d19e3e0..2ff1608bef 100644 --- a/testsuite/tests/numeric/should_compile/T7116.stdout +++ b/testsuite/tests/numeric/should_compile/T7116.stdout @@ -2,7 +2,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 22, types: 14, coercions: 0} -T7116.dl :: GHC.Types.Double -> GHC.Types.Double +dl :: Double -> Double [GblId, Arity=1, Caf=NoCafRefs, @@ -10,17 +10,17 @@ T7116.dl :: GHC.Types.Double -> GHC.Types.Double Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (x [Occ=Once!] :: GHC.Types.Double) -> + Tmpl= \ (x [Occ=Once!] :: Double) -> case x of _ [Occ=Dead] { GHC.Types.D# y -> GHC.Types.D# (GHC.Prim.+## y y) }}] -T7116.dl = - \ (x :: GHC.Types.Double) -> +dl = + \ (x :: Double) -> case x of _ [Occ=Dead] { GHC.Types.D# y -> GHC.Types.D# (GHC.Prim.+## y y) } -T7116.dr :: GHC.Types.Double -> GHC.Types.Double +dr :: Double -> Double [GblId, Arity=1, Caf=NoCafRefs, @@ -28,13 +28,13 @@ T7116.dr :: GHC.Types.Double -> GHC.Types.Double Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (x [Occ=Once!] :: GHC.Types.Double) -> + Tmpl= \ (x [Occ=Once!] :: Double) -> case x of _ [Occ=Dead] { GHC.Types.D# x1 -> GHC.Types.D# (GHC.Prim.+## x1 x1) }}] -T7116.dr = T7116.dl +dr = dl -T7116.fl :: GHC.Types.Float -> GHC.Types.Float +fl :: Float -> Float [GblId, Arity=1, Caf=NoCafRefs, @@ -42,17 +42,17 @@ T7116.fl :: GHC.Types.Float -> GHC.Types.Float Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (x [Occ=Once!] :: GHC.Types.Float) -> + Tmpl= \ (x [Occ=Once!] :: Float) -> case x of _ [Occ=Dead] { GHC.Types.F# y -> GHC.Types.F# (GHC.Prim.plusFloat# y y) }}] -T7116.fl = - \ (x :: GHC.Types.Float) -> +fl = + \ (x :: Float) -> case x of _ [Occ=Dead] { GHC.Types.F# y -> GHC.Types.F# (GHC.Prim.plusFloat# y y) } -T7116.fr :: GHC.Types.Float -> GHC.Types.Float +fr :: Float -> Float [GblId, Arity=1, Caf=NoCafRefs, @@ -60,11 +60,11 @@ T7116.fr :: GHC.Types.Float -> GHC.Types.Float Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (x [Occ=Once!] :: GHC.Types.Float) -> + Tmpl= \ (x [Occ=Once!] :: Float) -> case x of _ [Occ=Dead] { GHC.Types.F# x1 -> GHC.Types.F# (GHC.Prim.plusFloat# x1 x1) }}] -T7116.fr = T7116.fl +fr = fl diff --git a/testsuite/tests/parser/should_compile/T2245.stderr b/testsuite/tests/parser/should_compile/T2245.stderr index 3a5f21ad21..53b738832f 100644 --- a/testsuite/tests/parser/should_compile/T2245.stderr +++ b/testsuite/tests/parser/should_compile/T2245.stderr @@ -11,12 +11,12 @@ T2245.hs:5:10: Warning: ‘fromRational’ and (either ‘recip’ or ‘/’) In the instance declaration for ‘Fractional T’ -T2245.hs:7:38: Warning: +T2245.hs:7:29: Warning: Defaulting the following constraint(s) to type ‘T’ - (Read b0) arising from a use of ‘read’ at T2245.hs:7:38-41 - (Ord b0) arising from a use of ‘<’ at T2245.hs:7:27 (Fractional b0) arising from the literal ‘1e400’ at T2245.hs:7:29-33 - In the second argument of ‘(.)’, namely ‘read’ + (Ord b0) arising from a use of ‘<’ at T2245.hs:7:27 + (Read b0) arising from a use of ‘read’ at T2245.hs:7:38-41 + In the second argument of ‘(<)’, namely ‘1e400’ + In the first argument of ‘(.)’, namely ‘(< 1e400)’ In the second argument of ‘(.)’, namely ‘(< 1e400) . read’ - In the second argument of ‘($)’, namely ‘show . (< 1e400) . read’ diff --git a/testsuite/tests/perf/compiler/T5837.hs b/testsuite/tests/perf/compiler/T5837.hs index c2d0f10366..6ebbd65bd5 100644 --- a/testsuite/tests/perf/compiler/T5837.hs +++ b/testsuite/tests/perf/compiler/T5837.hs @@ -7,3 +7,47 @@ type instance TF (a,b) = (TF a, TF b) t :: (a ~ TF (a,Int)) => Int t = undefined + +{- + + [G] a ~ TF (a,Int) -- a = a_am1 +--> + [G] TF (a,Int) ~ fsk -- fsk = fsk_am8 +inert [G] fsk ~ a + +---> + [G] fsk ~ (TF a, TF Int) +inert [G] fsk ~ a + +---> + a ~ (TF a, TF Int) +inert [G] fsk ~ a + +---> (attempting to flatten (TF a) so that it does not mention a + TF a ~ fsk2 +inert a ~ (fsk2, TF Int) +inert fsk ~ (fsk2, TF Int) + +---> (substitute for a) + TF (fsk2, TF Int) ~ fsk2 +inert a ~ (fsk2, TF Int) +inert fsk ~ (fsk2, TF Int) + +---> (top-level reduction, re-orient) + fsk2 ~ (TF fsk2, TF Int) +inert a ~ (fsk2, TF Int) +inert fsk ~ (fsk2, TF Int) + +---> (attempt to flatten (TF fsk2) to get rid of fsk2 + TF fsk2 ~ fsk3 + fsk2 ~ (fsk3, TF Int) +inert a ~ (fsk2, TF Int) +inert fsk ~ (fsk2, TF Int) + +---> + TF fsk2 ~ fsk3 +inert fsk2 ~ (fsk3, TF Int) +inert a ~ ((fsk3, TF Int), TF Int) +inert fsk ~ ((fsk3, TF Int), TF Int) + +-}
\ No newline at end of file diff --git a/testsuite/tests/perf/compiler/T5837.stderr b/testsuite/tests/perf/compiler/T5837.stderr index 56d8ec9cb6..193bff1728 100644 --- a/testsuite/tests/perf/compiler/T5837.stderr +++ b/testsuite/tests/perf/compiler/T5837.stderr @@ -2,160 +2,160 @@ T5837.hs:8:6: Type function application stack overflow; size = 51 Use -ftype-function-depth=N to increase stack size to N - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - a)))))))))))))))))))))))))))))))))))))))))))))))))), - TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - Int))))))))))))))))))))))))))))))))))))))))))))))))))) - ~ TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - (TF - a))))))))))))))))))))))))))))))))))))))))))))))))) + TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + a))))))))))))))))))))))))))))))))))))))))))))))))) + ~ (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + a)))))))))))))))))))))))))))))))))))))))))))))))))), + TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + (TF + Int))))))))))))))))))))))))))))))))))))))))))))))))))) In the ambiguity check for: forall a. (a ~ TF (a, Int)) => Int In the type signature for ‘t’: t :: (a ~ TF (a, Int)) => Int diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 1a9dfcb297..3bce7ce417 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -454,7 +454,7 @@ test('T5837', # 40000000 (x86/Linux) # 2013-11-13: 45520936 (x86/Windows, 64bit machine) # 2041-09-03: 37096484 (Windows laptop, w/w for INLINABLE things - (wordsize(64), 75765728, 10)]) + (wordsize(64), 651924880, 10)]) # sample: 3926235424 (amd64/Linux, 15/2/2012) # 2012-10-02 81879216 # 2012-09-20 87254264 amd64/Linux @@ -463,6 +463,8 @@ test('T5837', # for constraints solving # 2014-08-29 73639840 amd64/Linux, w/w for INLINABLE things # 2014-10-08 73639840 amd64/Linux, Burning Bridges and other small changes + # 2014-11-02 651924880 Linux, Accept big regression; + # See Note [An alternative story for the inert substitution] in TcFlatten ], compile_fail,['-ftype-function-depth=50']) diff --git a/testsuite/tests/polykinds/T7438.stderr b/testsuite/tests/polykinds/T7438.stderr index b84465545f..4616576e0d 100644 --- a/testsuite/tests/polykinds/T7438.stderr +++ b/testsuite/tests/polykinds/T7438.stderr @@ -1,19 +1,19 @@ -
-T7438.hs:6:14:
- Couldn't match expected type ‘t1’ with actual type ‘t’
- ‘t’ is untouchable
- inside the constraints (t2 ~ t3)
- bound by a pattern with constructor
- Nil :: forall (k :: BOX) (b :: k). Thrist b b,
- in an equation for ‘go’
- at T7438.hs:6:4-6
- ‘t’ is a rigid type variable bound by
- the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1
- ‘t1’ is a rigid type variable bound by
- the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1
- Possible fix: add a type signature for ‘go’
- Relevant bindings include
- acc :: t (bound at T7438.hs:6:8)
- go :: Thrist t2 t3 -> t -> t1 (bound at T7438.hs:6:1)
- In the expression: acc
- In an equation for ‘go’: go Nil acc = acc
+ +T7438.hs:6:14: + Couldn't match expected type ‘t1’ with actual type ‘t’ + ‘t’ is untouchable + inside the constraints (t2 ~ t3) + bound by a pattern with constructor + Nil :: forall (k :: BOX) (b :: k). Thrist b b, + in an equation for ‘go’ + at T7438.hs:6:4-6 + ‘t’ is a rigid type variable bound by + the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1 + ‘t1’ is a rigid type variable bound by + the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1 + Possible fix: add a type signature for ‘go’ + Relevant bindings include + acc :: t (bound at T7438.hs:6:8) + go :: Thrist t2 t3 -> t -> t1 (bound at T7438.hs:6:1) + In the expression: acc + In an equation for ‘go’: go Nil acc = acc diff --git a/testsuite/tests/polykinds/T8132.stderr b/testsuite/tests/polykinds/T8132.stderr index 3156ec9e93..6c567de60a 100644 --- a/testsuite/tests/polykinds/T8132.stderr +++ b/testsuite/tests/polykinds/T8132.stderr @@ -1,4 +1,5 @@ -
-T8132.hs:1:1:
- Typeable instances can only be derived; replace the following instance:
- instance Typeable K -- Defined at T8132.hs:6:10
+ +T8132.hs:6:10: + Typeable instances can only be derived + Try ‘deriving instance Typeable K’ + (requires StandaloneDeriving) diff --git a/testsuite/tests/rebindable/rebindable6.stderr b/testsuite/tests/rebindable/rebindable6.stderr index 4d22904d6e..a02563f3ca 100644 --- a/testsuite/tests/rebindable/rebindable6.stderr +++ b/testsuite/tests/rebindable/rebindable6.stderr @@ -23,16 +23,12 @@ rebindable6.hs:106:17: return b } rebindable6.hs:107:17: - No instance for (HasBind (IO (Maybe b) -> (Maybe b -> t1) -> t0)) + No instance for (HasFail ([Prelude.Char] -> t1)) arising from a do statement - The type variables ‘t0’, ‘t1’ are ambiguous - Relevant bindings include - g :: IO (Maybe b) (bound at rebindable6.hs:104:19) - test_do :: IO a -> IO (Maybe b) -> IO b - (bound at rebindable6.hs:104:9) + The type variable ‘t1’ is ambiguous Note: there is a potential instance available: - instance HasBind (IO a -> (a -> IO b) -> IO b) - -- Defined at rebindable6.hs:47:18 + instance HasFail (String -> IO a) + -- Defined at rebindable6.hs:57:18 In a stmt of a 'do' block: Just (b :: b) <- g In the expression: do { f; diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr index b0dda24f2c..dc03073428 100644 --- a/testsuite/tests/roles/should_compile/Roles13.stderr +++ b/testsuite/tests/roles/should_compile/Roles13.stderr @@ -2,18 +2,16 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 5, types: 9, coercions: 5} -a :: Roles13.Wrap Roles13.Age -> Roles13.Wrap Roles13.Age +a :: Wrap Age -> Wrap Age [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType] -a = \ (ds :: Roles13.Wrap Roles13.Age) -> ds +a = \ (ds :: Wrap Age) -> ds -Roles13.convert :: Roles13.Wrap Roles13.Age -> GHC.Types.Int +convert :: Wrap Age -> Int [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType] -Roles13.convert = +convert = a - `cast` (<Roles13.Wrap Roles13.Age>_R - -> Roles13.NTCo:Wrap[0] Roles13.NTCo:Age[0] - :: (Roles13.Wrap Roles13.Age -> Roles13.Wrap Roles13.Age) - ~R# (Roles13.Wrap Roles13.Age -> GHC.Types.Int)) + `cast` (<Wrap Age>_R -> Roles13.NTCo:Wrap[0] Roles13.NTCo:Age[0] + :: (Wrap Age -> Wrap Age) ~R# (Wrap Age -> Int)) diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index 10ab093442..558b360604 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -1,41 +1,36 @@ - -T8958.hs:1:31: Warning: - -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. -TYPE SIGNATURES -TYPE CONSTRUCTORS - type role Map nominal representational - newtype (Nominal k, Representational v) => Map k v = MkMap [(k, v)] - Promotable - class Nominal a - type role Representational representational - class Representational a -COERCION AXIOMS - axiom T8958.NTCo:Map :: Map k v = [(k, v)] -INSTANCES - instance [incoherent] Nominal a -- Defined at T8958.hs:7:10 - instance [incoherent] Representational a - -- Defined at T8958.hs:10:10 -Dependent modules: [] -Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, - integer-<IMPL>-<VERSION>] - -==================== Typechecker ==================== -AbsBinds [a] [] - {Exports: [T8958.$fRepresentationala <= $dRepresentational - <>] - Exported types: T8958.$fRepresentationala [InlPrag=[ALWAYS] CONLIKE] - :: forall a. Representational a - [LclIdX[DFunId], - Str=DmdType, - Unf=DFun: \ (@ a) -> T8958.D:Representational TYPE a] - Binds: $dRepresentational = T8958.D:Representational} -AbsBinds [a] [] - {Exports: [T8958.$fNominala <= $dNominal - <>] - Exported types: T8958.$fNominala [InlPrag=[ALWAYS] CONLIKE] - :: forall a. Nominal a - [LclIdX[DFunId], - Str=DmdType, - Unf=DFun: \ (@ a) -> T8958.D:Nominal TYPE a] - Binds: $dNominal = T8958.D:Nominal} - +
+T8958.hs:1:31: Warning:
+ -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
+TYPE SIGNATURES
+TYPE CONSTRUCTORS
+ type role Map nominal representational
+ newtype (Nominal k, Representational v) => Map k v = MkMap [(k, v)]
+ Promotable
+ class Nominal a
+ type role Representational representational
+ class Representational a
+COERCION AXIOMS
+ axiom T8958.NTCo:Map :: Map k v = [(k, v)]
+INSTANCES
+ instance [incoherent] Nominal a -- Defined at T8958.hs:7:10
+ instance [incoherent] Representational a
+ -- Defined at T8958.hs:10:10
+Dependent modules: []
+Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0,
+ integer-gmp-0.5.1.0]
+
+==================== Typechecker ====================
+AbsBinds [a] []
+ {Exports: [T8958.$fRepresentationala <= $dRepresentational
+ <>]
+ Exported types: T8958.$fRepresentationala
+ :: forall a. Representational a
+ [LclIdX[DFunId], Str=DmdType]
+ Binds: $dRepresentational = T8958.D:Representational}
+AbsBinds [a] []
+ {Exports: [T8958.$fNominala <= $dNominal
+ <>]
+ Exported types: T8958.$fNominala :: forall a. Nominal a
+ [LclIdX[DFunId], Str=DmdType]
+ Binds: $dNominal = T8958.D:Nominal}
+
diff --git a/testsuite/tests/simplCore/should_compile/EvalTest.stdout b/testsuite/tests/simplCore/should_compile/EvalTest.stdout index 25ed3203f5..8bc22a42f2 100644 --- a/testsuite/tests/simplCore/should_compile/EvalTest.stdout +++ b/testsuite/tests/simplCore/should_compile/EvalTest.stdout @@ -1 +1 @@ -rght [Dmd=<S,U>] :: EvalTest.AList a1 +rght [Dmd=<S,U>] :: AList a1 diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr index 21e822b318..7cc1abe5dc 100644 --- a/testsuite/tests/simplCore/should_compile/T3717.stderr +++ b/testsuite/tests/simplCore/should_compile/T3717.stderr @@ -14,7 +14,7 @@ T3717.$wfoo = } end Rec } -T3717.foo [InlPrag=INLINE[0]] :: GHC.Types.Int -> GHC.Types.Int +foo [InlPrag=INLINE[0]] :: Int -> Int [GblId, Arity=1, Caf=NoCafRefs, @@ -22,12 +22,12 @@ T3717.foo [InlPrag=INLINE[0]] :: GHC.Types.Int -> GHC.Types.Int Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (w [Occ=Once!] :: GHC.Types.Int) -> + Tmpl= \ (w [Occ=Once!] :: Int) -> case w of _ [Occ=Dead] { GHC.Types.I# ww1 [Occ=Once] -> case T3717.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } }}] -T3717.foo = - \ (w :: GHC.Types.Int) -> +foo = + \ (w :: Int) -> case w of _ [Occ=Dead] { GHC.Types.I# ww1 -> case T3717.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } } diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index 506e342012..6609024183 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -13,15 +13,14 @@ $wxs = } end Rec } -T3772.foo [InlPrag=NOINLINE] :: GHC.Types.Int -> () +foo [InlPrag=NOINLINE] :: Int -> () [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U(U)>] -T3772.foo = - \ (n :: GHC.Types.Int) -> +foo = + \ (n :: Int) -> case n of _ [Occ=Dead] { GHC.Types.I# y -> - case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.<# 0 y) - of _ [Occ=Dead] { - GHC.Types.False -> GHC.Tuple.(); - GHC.Types.True -> $wxs y + case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# 0 y) of _ [Occ=Dead] { + False -> GHC.Tuple.(); + True -> $wxs y } } diff --git a/testsuite/tests/simplCore/should_compile/T4201.stdout b/testsuite/tests/simplCore/should_compile/T4201.stdout index 6ff4692854..51b159627e 100644 --- a/testsuite/tests/simplCore/should_compile/T4201.stdout +++ b/testsuite/tests/simplCore/should_compile/T4201.stdout @@ -1,3 +1,3 @@ {- Arity: 1, HasNoCafRefs, Strictness: <S,1*U()>m, Unfolding: InlineRule (0, True, True) - Eta.bof `cast` (Sym (Eta.NTCo:Foo[0]) ->_R <Eta.T>_R) -} + bof `cast` (Sym (NTCo:Foo[0]) ->_R <T>_R) -} diff --git a/testsuite/tests/simplCore/should_compile/T4306.stdout b/testsuite/tests/simplCore/should_compile/T4306.stdout index b2a93ff1cc..3d52e94830 100644 --- a/testsuite/tests/simplCore/should_compile/T4306.stdout +++ b/testsuite/tests/simplCore/should_compile/T4306.stdout @@ -1 +1 @@ - $wupd :: GHC.Prim.Double# -> GHC.Prim.Double# + $wupd :: Double# -> Double# diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index 9729289ea6..7cc25b9f06 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -3,27 +3,21 @@ Result size of Tidy Core = {terms: 54, types: 38, coercions: 0} Rec { -T4908.f_$s$wf [Occ=LoopBreaker] - :: GHC.Prim.Int# - -> GHC.Types.Int -> GHC.Prim.Int# -> GHC.Types.Bool +T4908.f_$s$wf [Occ=LoopBreaker] :: Int# -> Int -> Int# -> Bool [GblId, Arity=3, Caf=NoCafRefs, Str=DmdType <S,1*U><L,A><L,U>] T4908.f_$s$wf = - \ (sc :: GHC.Prim.Int#) - (sc1 :: GHC.Types.Int) - (sc2 :: GHC.Prim.Int#) -> + \ (sc :: Int#) (sc1 :: Int) (sc2 :: Int#) -> case sc of ds { __DEFAULT -> case sc2 of ds1 { - __DEFAULT -> T4908.f_$s$wf (GHC.Prim.-# ds 1) sc1 ds1; + __DEFAULT -> T4908.f_$s$wf (-# ds 1) sc1 ds1; 0 -> GHC.Types.True }; 0 -> GHC.Types.True } end Rec } -T4908.$wf [InlPrag=[0]] - :: GHC.Prim.Int# - -> (GHC.Types.Int, GHC.Types.Int) -> GHC.Types.Bool +T4908.$wf [InlPrag=[0]] :: Int# -> (Int, Int) -> Bool [GblId, Arity=2, Caf=NoCafRefs, @@ -31,13 +25,13 @@ T4908.$wf [InlPrag=[0]] Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 20] 101 20}] T4908.$wf = - \ (ww :: GHC.Prim.Int#) (w :: (GHC.Types.Int, GHC.Types.Int)) -> + \ (ww :: Int#) (w :: (Int, Int)) -> case ww of ds { __DEFAULT -> case w of _ [Occ=Dead] { (a, b) -> - case b of _ [Occ=Dead] { GHC.Types.I# ds1 -> + case b of _ [Occ=Dead] { I# ds1 -> case ds1 of ds2 { - __DEFAULT -> T4908.f_$s$wf (GHC.Prim.-# ds 1) a ds2; + __DEFAULT -> T4908.f_$s$wf (-# ds 1) a ds2; 0 -> GHC.Types.True } } @@ -45,9 +39,7 @@ T4908.$wf = 0 -> GHC.Types.True } -T4908.f [InlPrag=INLINE[0]] - :: GHC.Types.Int - -> (GHC.Types.Int, GHC.Types.Int) -> GHC.Types.Bool +f [InlPrag=INLINE[0]] :: Int -> (Int, Int) -> Bool [GblId, Arity=2, Caf=NoCafRefs, @@ -55,21 +47,16 @@ T4908.f [InlPrag=INLINE[0]] Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (w [Occ=Once!] :: GHC.Types.Int) - (w1 [Occ=Once] :: (GHC.Types.Int, GHC.Types.Int)) -> - case w of _ [Occ=Dead] { GHC.Types.I# ww1 [Occ=Once] -> - T4908.$wf ww1 w1 - }}] -T4908.f = - \ (w :: GHC.Types.Int) (w1 :: (GHC.Types.Int, GHC.Types.Int)) -> - case w of _ [Occ=Dead] { GHC.Types.I# ww1 -> T4908.$wf ww1 w1 } + Tmpl= \ (w [Occ=Once!] :: Int) (w1 [Occ=Once] :: (Int, Int)) -> + case w of _ [Occ=Dead] { I# ww1 [Occ=Once] -> T4908.$wf ww1 w1 }}] +f = + \ (w :: Int) (w1 :: (Int, Int)) -> + case w of _ [Occ=Dead] { I# ww1 -> T4908.$wf ww1 w1 } ------ Local rules for imported ids -------- "SC:$wf0" [0] - forall (sc :: GHC.Prim.Int#) - (sc1 :: GHC.Types.Int) - (sc2 :: GHC.Prim.Int#). + forall (sc :: Int#) (sc1 :: Int) (sc2 :: Int#). T4908.$wf sc (sc1, GHC.Types.I# sc2) = T4908.f_$s$wf sc sc1 sc2 diff --git a/testsuite/tests/simplCore/should_compile/T4918.stdout b/testsuite/tests/simplCore/should_compile/T4918.stdout index 708be353c4..b0a072d2b0 100644 --- a/testsuite/tests/simplCore/should_compile/T4918.stdout +++ b/testsuite/tests/simplCore/should_compile/T4918.stdout @@ -1,2 +1,2 @@ - {- HasNoCafRefs, Strictness: m, Unfolding: (GHC.Types.C# 'p') -} - {- HasNoCafRefs, Strictness: m, Unfolding: (GHC.Types.C# 'q') -} + {- HasNoCafRefs, Strictness: m, Unfolding: (C# 'p') -} + {- HasNoCafRefs, Strictness: m, Unfolding: (C# 'q') -} diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index 5f0aad2525..1a54d0d5bc 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -2,36 +2,34 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 23, types: 11, coercions: 0} -lvl :: [GHC.Types.Char] +lvl :: [Char] [GblId, Str=DmdType] lvl = GHC.CString.unpackCString# "Too small"# -T4930.foo1 :: GHC.Types.Int +T4930.foo1 :: Int [GblId, Str=DmdType b] -T4930.foo1 = GHC.Err.error @ GHC.Types.Int lvl +T4930.foo1 = error @ Int lvl -T4930.foo :: GHC.Types.Int -> GHC.Types.Int +foo :: Int -> Int [GblId, Arity=1, Str=DmdType <S,1*U(U)>m, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (n [Occ=Once!] :: GHC.Types.Int) -> + Tmpl= \ (n [Occ=Once!] :: Int) -> case n of _ [Occ=Dead] { GHC.Types.I# x -> - case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.<# x 5) - of _ [Occ=Dead] { - GHC.Types.False -> GHC.Types.I# (GHC.Prim.+# x 5); - GHC.Types.True -> T4930.foo1 + case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x 5) of _ [Occ=Dead] { + False -> GHC.Types.I# (GHC.Prim.+# x 5); + True -> T4930.foo1 } }}] -T4930.foo = - \ (n :: GHC.Types.Int) -> +foo = + \ (n :: Int) -> case n of _ [Occ=Dead] { GHC.Types.I# x -> - case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.<# x 5) - of _ [Occ=Dead] { - GHC.Types.False -> GHC.Types.I# (GHC.Prim.+# x 5); - GHC.Types.True -> T4930.foo1 + case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x 5) of _ [Occ=Dead] { + False -> GHC.Types.I# (GHC.Prim.+# x 5); + True -> T4930.foo1 } } diff --git a/testsuite/tests/simplCore/should_compile/T5366.stdout b/testsuite/tests/simplCore/should_compile/T5366.stdout index ccc1561d05..df0f9ba05d 100644 --- a/testsuite/tests/simplCore/should_compile/T5366.stdout +++ b/testsuite/tests/simplCore/should_compile/T5366.stdout @@ -1 +1 @@ - case ds of _ [Occ=Dead] { T5366.Bar dt dt1 -> GHC.Types.I# dt } + case ds of _ [Occ=Dead] { Bar dt dt1 -> GHC.Types.I# dt } diff --git a/testsuite/tests/simplCore/should_compile/T6056.hs b/testsuite/tests/simplCore/should_compile/T6056.hs index e24631d234..d2d8349f65 100644 --- a/testsuite/tests/simplCore/should_compile/T6056.hs +++ b/testsuite/tests/simplCore/should_compile/T6056.hs @@ -1,8 +1,6 @@ module T6056 where import T6056a -foo1 :: Int -> (Maybe Int, [Int]) -foo1 x = smallerAndRest x [x] +foo :: Int -> (Maybe Int, [Int]) +foo x = smallerAndRest x [x] -foo2 :: Integer -> (Maybe Integer, [Integer]) -foo2 x = smallerAndRest x [x] diff --git a/testsuite/tests/simplCore/should_compile/T6056.stderr b/testsuite/tests/simplCore/should_compile/T6056.stderr index 50c7e66f0a..5695bd5c2f 100644 --- a/testsuite/tests/simplCore/should_compile/T6056.stderr +++ b/testsuite/tests/simplCore/should_compile/T6056.stderr @@ -1,12 +1,6 @@ Rule fired: foldr/nil -Rule fired: foldr/nil -Rule fired: SPEC/T6056 $wsmallerAndRest @ Integer Rule fired: SPEC/T6056 $wsmallerAndRest @ Int Rule fired: Class op < -Rule fired: Class op < -Rule fired: SPEC/T6056 $wsmallerAndRest @ Integer -Rule fired: SPEC/T6056 $wsmallerAndRest @ Integer Rule fired: SPEC/T6056 $wsmallerAndRest @ Int Rule fired: SPEC/T6056 $wsmallerAndRest @ Int -Rule fired: SPEC/T6056 $wsmallerAndRest @ Integer Rule fired: SPEC/T6056 $wsmallerAndRest @ Int diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index 5d10285099..2cd7c2100e 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -2,7 +2,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 36, types: 29, coercions: 0} -T7360.$WFoo3 [InlPrag=INLINE] :: GHC.Types.Int -> T7360.Foo +T7360.$WFoo3 [InlPrag=INLINE] :: Int -> Foo [GblId[DataConWrapper], Arity=1, Caf=NoCafRefs, @@ -10,20 +10,20 @@ T7360.$WFoo3 [InlPrag=INLINE] :: GHC.Types.Int -> T7360.Foo Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) - Tmpl= \ (dt [Occ=Once!] :: GHC.Types.Int) -> + Tmpl= \ (dt [Occ=Once!] :: Int) -> case dt of _ [Occ=Dead] { GHC.Types.I# dt [Occ=Once] -> T7360.Foo3 dt }}] T7360.$WFoo3 = - \ (dt [Occ=Once!] :: GHC.Types.Int) -> + \ (dt [Occ=Once!] :: Int) -> case dt of _ [Occ=Dead] { GHC.Types.I# dt [Occ=Once] -> T7360.Foo3 dt } -T7360.fun1 [InlPrag=NOINLINE] :: T7360.Foo -> () +fun1 [InlPrag=NOINLINE] :: Foo -> () [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>] -T7360.fun1 = - \ (x :: T7360.Foo) -> +fun1 = + \ (x :: Foo) -> case x of _ [Occ=Dead] { __DEFAULT -> GHC.Tuple.() } T7360.fun4 :: () @@ -31,9 +31,9 @@ T7360.fun4 :: () Str=DmdType, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}] -T7360.fun4 = T7360.fun1 T7360.Foo1 +T7360.fun4 = fun1 T7360.Foo1 -T7360.fun3 :: GHC.Types.Int +T7360.fun3 :: Int [GblId, Caf=NoCafRefs, Str=DmdType m, @@ -41,7 +41,7 @@ T7360.fun3 :: GHC.Types.Int WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7360.fun3 = GHC.Types.I# 0 -T7360.fun2 :: forall a. [a] -> ((), GHC.Types.Int) +fun2 :: forall a. [a] -> ((), Int) [GblId, Arity=1, Str=DmdType <L,1*U>m, @@ -57,7 +57,7 @@ T7360.fun2 :: forall a. [a] -> ((), GHC.Types.Int) GHC.Types.I# ww2 } })}] -T7360.fun2 = +fun2 = \ (@ a) (x :: [a]) -> (T7360.fun4, case x of wild { diff --git a/testsuite/tests/simplCore/should_compile/T7865.stdout b/testsuite/tests/simplCore/should_compile/T7865.stdout index 93c495d1d7..56419a939c 100644 --- a/testsuite/tests/simplCore/should_compile/T7865.stdout +++ b/testsuite/tests/simplCore/should_compile/T7865.stdout @@ -1,4 +1,4 @@ -T7865.expensive [InlPrag=NOINLINE] -T7865.expensive = - case T7865.expensive sc of _ [Occ=Dead] { GHC.Types.I# x -> - (case T7865.expensive x of _ [Occ=Dead] { GHC.Types.I# x1 -> +expensive [InlPrag=NOINLINE] :: Int -> Int +expensive = + case expensive sc of _ [Occ=Dead] { GHC.Types.I# x -> + (case expensive x of _ [Occ=Dead] { GHC.Types.I# x1 -> diff --git a/testsuite/tests/simplCore/should_compile/T8832.stdout b/testsuite/tests/simplCore/should_compile/T8832.stdout index 271963122d..aefe486c0c 100644 --- a/testsuite/tests/simplCore/should_compile/T8832.stdout +++ b/testsuite/tests/simplCore/should_compile/T8832.stdout @@ -1,10 +1,10 @@ -T8832.i = GHC.Types.I# 0 -T8832.i8 = GHC.Int.I8# 0 -T8832.i16 = GHC.Int.I16# 0 -T8832.i32 = GHC.Int.I32# 0 -T8832.i64 = GHC.Int.I64# 0 -T8832.w = GHC.Types.W# (__word 0) -T8832.w8 = GHC.Word.W8# (__word 0) -T8832.w16 = GHC.Word.W16# (__word 0) -T8832.w32 = GHC.Word.W32# (__word 0) -T8832.w64 = GHC.Word.W64# (__word 0) +i = GHC.Types.I# 0 +i8 = GHC.Int.I8# 0 +i16 = GHC.Int.I16# 0 +i32 = GHC.Int.I32# 0 +i64 = GHC.Int.I64# 0 +w = GHC.Types.W# (__word 0) +w8 = GHC.Word.W8# (__word 0) +w16 = GHC.Word.W16# (__word 0) +w32 = GHC.Word.W32# (__word 0) +w64 = GHC.Word.W64# (__word 0) diff --git a/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 b/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 index d09293705f..2a3238ce0c 100644 --- a/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 +++ b/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 @@ -1,8 +1,8 @@ -T8832.i = GHC.Types.I# 0 -T8832.i8 = GHC.Int.I8# 0 -T8832.i16 = GHC.Int.I16# 0 -T8832.i32 = GHC.Int.I32# 0 -T8832.w = GHC.Types.W# (__word 0) -T8832.w8 = GHC.Word.W8# (__word 0) -T8832.w16 = GHC.Word.W16# (__word 0) -T8832.w32 = GHC.Word.W32# (__word 0) +i = GHC.Types.I# 0
+i8 = GHC.Int.I8# 0
+i16 = GHC.Int.I16# 0
+i32 = GHC.Int.I32# 0
+w = GHC.Types.W# (__word 0)
+w8 = GHC.Word.W8# (__word 0)
+w16 = GHC.Word.W16# (__word 0)
+w32 = GHC.Word.W32# (__word 0)
diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr index e66eecfc0a..938a07204b 100644 --- a/testsuite/tests/simplCore/should_compile/T9400.stderr +++ b/testsuite/tests/simplCore/should_compile/T9400.stderr @@ -2,35 +2,35 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 23, types: 16, coercions: 0} -T9400.main :: GHC.Types.IO () +main :: IO () [GblId, Str=DmdType] -T9400.main = - GHC.Base.>> - @ GHC.Types.IO +main = + >> + @ IO GHC.Base.$fMonadIO @ () @ () - (System.IO.putStrLn (GHC.CString.unpackCString# "c"#)) - (GHC.Base.>> - @ GHC.Types.IO + (putStrLn (unpackCString# "c"#)) + (>> + @ IO GHC.Base.$fMonadIO @ () @ () - (System.IO.putStrLn (GHC.CString.unpackCString# "x"#)) - (GHC.Base.>> - @ GHC.Types.IO + (putStrLn (unpackCString# "x"#)) + (>> + @ IO GHC.Base.$fMonadIO @ () @ () - (System.IO.putStrLn (GHC.CString.unpackCString# "z"#)) - (GHC.Base.>> - @ GHC.Types.IO + (putStrLn (unpackCString# "z"#)) + (>> + @ IO GHC.Base.$fMonadIO @ () @ () - (System.IO.putStrLn (GHC.CString.unpackCString# "efg"#)) + (putStrLn (unpackCString# "efg"#)) (Control.Exception.Base.patError - @ (GHC.Types.IO ()) "T9400.hs:(17,5)-(18,29)|case"#)))) + @ (IO ()) "T9400.hs:(17,5)-(18,29)|case"#)))) diff --git a/testsuite/tests/simplCore/should_compile/rule2.stderr b/testsuite/tests/simplCore/should_compile/rule2.stderr index 2c29fa40d5..a9f3a3b0f7 100644 --- a/testsuite/tests/simplCore/should_compile/rule2.stderr +++ b/testsuite/tests/simplCore/should_compile/rule2.stderr @@ -22,7 +22,7 @@ Total ticks: 11 1 m 1 a 1 m - 1 a + 1 b 1 m 1 b 9 SimplifierDone 9 diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index aee86c36fa..29c8a91301 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -2,11 +2,11 @@ ==================== Tidy Core ==================== Result size of Tidy Core = {terms: 162, types: 61, coercions: 0} -Roman.foo3 :: GHC.Types.Int +Roman.foo3 :: Int [GblId, Str=DmdType b] Roman.foo3 = Control.Exception.Base.patError - @ GHC.Types.Int "spec-inline.hs:(19,5)-(29,25)|function go"# + @ Int "spec-inline.hs:(19,5)-(29,25)|function go"# Rec { Roman.foo_$s$wgo [Occ=LoopBreaker] @@ -24,38 +24,34 @@ Roman.foo_$s$wgo = (GHC.Prim.+# (GHC.Prim.+# (GHC.Prim.+# sc1 sc1) sc1) sc1) sc1) sc1) sc1 } in - case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.<=# sc 0) + case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<=# sc 0) of _ [Occ=Dead] { - GHC.Types.False -> - case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.<# sc 100) + False -> + case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# sc 100) of _ [Occ=Dead] { - GHC.Types.False -> - case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.<# sc 500) + False -> + case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# sc 500) of _ [Occ=Dead] { - GHC.Types.False -> - Roman.foo_$s$wgo (GHC.Prim.-# sc 1) (GHC.Prim.+# a a); - GHC.Types.True -> Roman.foo_$s$wgo (GHC.Prim.-# sc 3) a + False -> Roman.foo_$s$wgo (GHC.Prim.-# sc 1) (GHC.Prim.+# a a); + True -> Roman.foo_$s$wgo (GHC.Prim.-# sc 3) a }; - GHC.Types.True -> Roman.foo_$s$wgo (GHC.Prim.-# sc 2) sc1 + True -> Roman.foo_$s$wgo (GHC.Prim.-# sc 2) sc1 }; - GHC.Types.True -> 0 + True -> 0 } end Rec } -Roman.$wgo [InlPrag=[0]] - :: GHC.Base.Maybe GHC.Types.Int - -> GHC.Base.Maybe GHC.Types.Int -> GHC.Prim.Int# +Roman.$wgo [InlPrag=[0]] :: Maybe Int -> Maybe Int -> GHC.Prim.Int# [GblId, Arity=2, Str=DmdType <S,1*U><S,1*U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 30] 256 0}] Roman.$wgo = - \ (w :: GHC.Base.Maybe GHC.Types.Int) - (w1 :: GHC.Base.Maybe GHC.Types.Int) -> + \ (w :: Maybe Int) (w1 :: Maybe Int) -> case w1 of _ [Occ=Dead] { - GHC.Base.Nothing -> case Roman.foo3 of wild1 { }; - GHC.Base.Just x -> + Nothing -> case Roman.foo3 of wild1 { }; + Just x -> case x of _ [Occ=Dead] { GHC.Types.I# ipv -> let { a :: GHC.Prim.Int# @@ -68,48 +64,43 @@ Roman.$wgo = ipv) ipv } in case w of _ [Occ=Dead] { - GHC.Base.Nothing -> Roman.foo_$s$wgo 10 a; - GHC.Base.Just n -> + Nothing -> Roman.foo_$s$wgo 10 a; + Just n -> case n of _ [Occ=Dead] { GHC.Types.I# x2 -> - case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.<=# x2 0) + case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<=# x2 0) of _ [Occ=Dead] { - GHC.Types.False -> - case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.<# x2 100) + False -> + case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x2 100) of _ [Occ=Dead] { - GHC.Types.False -> - case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.<# x2 500) + False -> + case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x2 500) of _ [Occ=Dead] { - GHC.Types.False -> - Roman.foo_$s$wgo (GHC.Prim.-# x2 1) (GHC.Prim.+# a a); - GHC.Types.True -> Roman.foo_$s$wgo (GHC.Prim.-# x2 3) a + False -> Roman.foo_$s$wgo (GHC.Prim.-# x2 1) (GHC.Prim.+# a a); + True -> Roman.foo_$s$wgo (GHC.Prim.-# x2 3) a }; - GHC.Types.True -> Roman.foo_$s$wgo (GHC.Prim.-# x2 2) ipv + True -> Roman.foo_$s$wgo (GHC.Prim.-# x2 2) ipv }; - GHC.Types.True -> 0 + True -> 0 } } } } } -Roman.foo_go [InlPrag=INLINE[0]] - :: GHC.Base.Maybe GHC.Types.Int - -> GHC.Base.Maybe GHC.Types.Int -> GHC.Types.Int +Roman.foo_go [InlPrag=INLINE[0]] :: Maybe Int -> Maybe Int -> Int [GblId, Arity=2, Str=DmdType <S,1*U><S,1*U>m, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (w [Occ=Once] :: GHC.Base.Maybe GHC.Types.Int) - (w1 [Occ=Once] :: GHC.Base.Maybe GHC.Types.Int) -> + Tmpl= \ (w [Occ=Once] :: Maybe Int) (w1 [Occ=Once] :: Maybe Int) -> case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww }}] Roman.foo_go = - \ (w :: GHC.Base.Maybe GHC.Types.Int) - (w1 :: GHC.Base.Maybe GHC.Types.Int) -> + \ (w :: Maybe Int) (w1 :: Maybe Int) -> case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww } -Roman.foo2 :: GHC.Types.Int +Roman.foo2 :: Int [GblId, Caf=NoCafRefs, Str=DmdType m, @@ -117,15 +108,15 @@ Roman.foo2 :: GHC.Types.Int WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] Roman.foo2 = GHC.Types.I# 6 -Roman.foo1 :: GHC.Base.Maybe GHC.Types.Int +Roman.foo1 :: Maybe Int [GblId, Caf=NoCafRefs, Str=DmdType m2, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] -Roman.foo1 = GHC.Base.Just @ GHC.Types.Int Roman.foo2 +Roman.foo1 = GHC.Base.Just @ Int Roman.foo2 -Roman.foo :: GHC.Types.Int -> GHC.Types.Int +foo :: Int -> Int [GblId, Arity=1, Caf=NoCafRefs, @@ -133,12 +124,12 @@ Roman.foo :: GHC.Types.Int -> GHC.Types.Int Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (n [Occ=Once!] :: GHC.Types.Int) -> + Tmpl= \ (n [Occ=Once!] :: Int) -> case n of n1 { GHC.Types.I# _ [Occ=Dead] -> - Roman.foo_go (GHC.Base.Just @ GHC.Types.Int n1) Roman.foo1 + Roman.foo_go (GHC.Base.Just @ Int n1) Roman.foo1 }}] -Roman.foo = - \ (n :: GHC.Types.Int) -> +foo = + \ (n :: Int) -> case n of _ [Occ=Dead] { GHC.Types.I# ipv -> case Roman.foo_$s$wgo ipv 6 of ww { __DEFAULT -> GHC.Types.I# ww } } @@ -147,8 +138,8 @@ Roman.foo = ------ Local rules for imported ids -------- "SC:$wgo0" [0] forall (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#). - Roman.$wgo (GHC.Base.Just @ GHC.Types.Int (GHC.Types.I# sc)) - (GHC.Base.Just @ GHC.Types.Int (GHC.Types.I# sc1)) + Roman.$wgo (GHC.Base.Just @ Int (GHC.Types.I# sc)) + (GHC.Base.Just @ Int (GHC.Types.I# sc1)) = Roman.foo_$s$wgo sc sc1 diff --git a/testsuite/tests/th/T3319.stderr b/testsuite/tests/th/T3319.stderr index 214b1eff9f..f325ffb8dc 100644 --- a/testsuite/tests/th/T3319.stderr +++ b/testsuite/tests/th/T3319.stderr @@ -1,8 +1,8 @@ -T3319.hs:1:1: Splicing declarations - return - [ForeignD - (ImportF - CCall Unsafe "&" (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))] - ======> - T3319.hs:8:3-93 - foreign import ccall unsafe "static &foo" foo :: Ptr GHC.Tuple.() +T3319.hs:1:1: Splicing declarations
+ return
+ [ForeignD
+ (ImportF
+ CCall Unsafe "&" (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))]
+ ======>
+ T3319.hs:8:3-93
+ foreign import ccall unsafe "static &foo" foo :: Ptr GHC.Tuple.()
diff --git a/testsuite/tests/th/T3600.stderr b/testsuite/tests/th/T3600.stderr index 2cd8332ce9..a7f988416e 100644 --- a/testsuite/tests/th/T3600.stderr +++ b/testsuite/tests/th/T3600.stderr @@ -1,5 +1,5 @@ -T3600.hs:1:1: Splicing declarations - test - ======> - T3600.hs:5:3-6 - myFunction = (testFun1 [], testFun2 [], testFun2 "x") +T3600.hs:1:1: Splicing declarations
+ test
+ ======>
+ T3600.hs:5:3-6
+ myFunction = (testFun1 [], testFun2 [], testFun2 "x")
diff --git a/testsuite/tests/th/T5217.stderr b/testsuite/tests/th/T5217.stderr index 891bb7f94a..a749282710 100644 --- a/testsuite/tests/th/T5217.stderr +++ b/testsuite/tests/th/T5217.stderr @@ -1,14 +1,14 @@ T5217.hs:1:1: Splicing declarations
[d| data T a b
- where
- T1 :: Int -> T Int Char
- T2 :: a -> T a a
- T3 :: a -> T [a] a
- T4 :: a -> b -> T b [a] |]
+ where
+ T1 :: Int -> T Int Char
+ T2 :: a -> T a a
+ T3 :: a -> T [a] a
+ T4 :: a -> b -> T b [a] |]
======>
T5217.hs:(6,3)-(9,53)
data T a b
- = (b ~ Char, a ~ Int) => T1 Int |
- b ~ a => T2 a |
- a ~ [b] => T3 b |
- forall a. b ~ [a] => T4 a a
+ = (b ~ Char, a ~ Int) => T1 Int |
+ b ~ a => T2 a |
+ a ~ [b] => T3 b |
+ forall a. b ~ [a] => T4 a a
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 2981202300..3b7f86cc75 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -187,7 +187,7 @@ test('T5126', normal, compile, ['-v0']) test('T5217', normal, compile, ['-v0 -dsuppress-uniques -ddump-splices']) test('T5037', normal, compile, ['-v0']) test('TH_unboxedSingleton', normal, compile, ['-v0']) -test('T5290', normal, compile, ['-v0 -ddump-splices']) +test('T5290', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T5362', normal, compile, ['-v0']) test('TH_unresolvedInfix', @@ -211,7 +211,7 @@ test('T5452', normal, compile, ['-v0']) test('T5434', extra_clean(['T5434a.hi','T5434a.o']), multimod_compile, ['T5434','-v0 -Wall ' + config.ghc_th_way_flags]) -test('T5508', normal, compile, ['-v0 -ddump-splices']) +test('T5508', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('TH_Depends', [extra_clean(['TH_Depends_External.o', 'TH_Depends_External.hi', 'TH_Depends_external.txt'])], @@ -226,7 +226,7 @@ test('T5700', extra_clean(['T5700a.hi','T5700a.o']), ['T5700','-v0 -ddump-splices ' + config.ghc_th_way_flags]) test('T5721', normal, compile, ['-v0']) -test('TH_PromotedTuple', normal, compile, ['-v0 -ddump-splices']) +test('TH_PromotedTuple', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('TH_PromotedList', normal, compile, ['-v0']) test('TH_Promoted1Tuple', normal, compile_fail, ['-v0']) test('TH_RichKinds', normal, compile, ['-v0']) diff --git a/testsuite/tests/typecheck/should_compile/FD1.stderr b/testsuite/tests/typecheck/should_compile/FD1.stderr index 98ed785956..34ea4bff61 100644 --- a/testsuite/tests/typecheck/should_compile/FD1.stderr +++ b/testsuite/tests/typecheck/should_compile/FD1.stderr @@ -1,10 +1,6 @@ FD1.hs:16:1: - Could not deduce (a ~ (Int -> Int)) - from the context (E a (Int -> Int)) - bound by the type signature for - plus :: E a (Int -> Int) => Int -> a - at FD1.hs:15:9-38 + Couldn't match expected type ‘Int -> Int’ with actual type ‘a’ ‘a’ is a rigid type variable bound by the type signature for plus :: E a (Int -> Int) => Int -> a at FD1.hs:15:9 diff --git a/testsuite/tests/typecheck/should_compile/FD2.stderr b/testsuite/tests/typecheck/should_compile/FD2.stderr index 691d5b5b84..9ebfabee3b 100644 --- a/testsuite/tests/typecheck/should_compile/FD2.stderr +++ b/testsuite/tests/typecheck/should_compile/FD2.stderr @@ -1,17 +1,6 @@ FD2.hs:26:34: - Could not deduce (e ~ e1) - from the context (ShouldCompile.Foldable a) - bound by the class declaration for ‘ShouldCompile.Foldable’ - at FD2.hs:(17,1)-(26,39) - or from (Elem a e) - bound by the type signature for - foldr1 :: Elem a e => (e -> e -> e) -> a -> e - at FD2.hs:21:13-47 - or from (Elem a e1) - bound by the type signature for - mf :: Elem a e1 => e1 -> Maybe e1 -> Maybe e1 - at FD2.hs:24:18-54 + Couldn't match expected type ‘e1’ with actual type ‘e’ ‘e’ is a rigid type variable bound by the type signature for foldr1 :: Elem a e => (e -> e -> e) -> a -> e diff --git a/testsuite/tests/typecheck/should_compile/T3346.hs b/testsuite/tests/typecheck/should_compile/T3346.hs index 5b2cf060b8..c163cecd09 100644 --- a/testsuite/tests/typecheck/should_compile/T3346.hs +++ b/testsuite/tests/typecheck/should_compile/T3346.hs @@ -9,8 +9,8 @@ class EP a where from :: a -> Result a to :: Result a -> a -{-# RULES "rule1" forall x. to (from x) = x #-} -{-# RULES "rule2" forall x. from (to x) = x #-} +-- {-# RULES "rule1" forall x. to (from x) = x #-} +-- {-# RULES "rule2" forall x. from (to x) = x #-} foo :: EP a => a -> a -- This is typed in a way rather similarly to RULE rule1 diff --git a/testsuite/tests/typecheck/should_compile/T8474.hs b/testsuite/tests/typecheck/should_compile/T8474.hs index 72df3b85a6..5a0c50f5c5 100644 --- a/testsuite/tests/typecheck/should_compile/T8474.hs +++ b/testsuite/tests/typecheck/should_compile/T8474.hs @@ -9,11 +9,13 @@ slow_to_compile = do tst1 <- return 1 let ?tst1 = tst1 +{- let ?tst2 = tst1 let ?tst3 = tst1 let ?tst4 = tst1 let ?tst5 = tst1 let ?tst6 = tst1 let ?tst7 = tst1 +-} print $ D ?tst1
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_compile/T9708.hs b/testsuite/tests/typecheck/should_compile/T9708.hs new file mode 100644 index 0000000000..fa6deb2cdf --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T9708.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies #-} +module TcTypeNatSimple where + +import GHC.TypeLits +import Data.Proxy + +type family SomeFun (n :: Nat) + +ti7 :: (x <= y, y <= x) => Proxy (SomeFun x) -> Proxy y -> () +ti7 _ _ = () diff --git a/testsuite/tests/typecheck/should_compile/T9708.stderr b/testsuite/tests/typecheck/should_compile/T9708.stderr new file mode 100644 index 0000000000..fca5df7bc8 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T9708.stderr @@ -0,0 +1,17 @@ +
+T9708.hs:9:8:
+ Could not deduce (SomeFun x ~ SomeFun y)
+ from the context (x <= y, y <= x)
+ bound by the type signature for
+ ti7 :: (x <= y, y <= x) => Proxy (SomeFun x) -> Proxy y -> ()
+ at T9708.hs:9:8-61
+ NB: ‘SomeFun’ is a type function, and may not be injective
+ Expected type: Proxy (SomeFun x) -> Proxy y -> ()
+ Actual type: Proxy (SomeFun y) -> Proxy y -> ()
+ In the ambiguity check for:
+ forall (x :: Nat) (y :: Nat).
+ (x <= y, y <= x) =>
+ Proxy (SomeFun x) -> Proxy y -> ()
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the type signature for ‘ti7’:
+ ti7 :: (x <= y, y <= x) => Proxy (SomeFun x) -> Proxy y -> ()
diff --git a/testsuite/tests/typecheck/should_compile/TcTypeNatSimple.hs b/testsuite/tests/typecheck/should_compile/TcTypeNatSimple.hs index 78661730cc..c692c3f725 100644 --- a/testsuite/tests/typecheck/should_compile/TcTypeNatSimple.hs +++ b/testsuite/tests/typecheck/should_compile/TcTypeNatSimple.hs @@ -62,8 +62,8 @@ e18 = id -------------------------------------------------------------------------------- -- Test interactions with inerts -ti1 :: Proxy (x + y) -> Proxy x -> () -ti1 _ _ = () +-- ti1 :: Proxy (x + y) -> Proxy x -> () +-- ti1 _ _ = () ti2 :: Proxy (y + x) -> Proxy x -> () ti2 _ _ = () @@ -80,15 +80,8 @@ ti5 _ = () ti6 :: Proxy (y ^ 2) -> () ti6 _ = () -type family SomeFun (n :: Nat) - -ti7 :: (x <= y, y <= x) => Proxy (SomeFun x) -> Proxy y -> () -ti7 _ _ = () - ti8 :: Proxy (x - y) -> Proxy x -> () ti8 _ _ = () ti9 :: Proxy (y - x) -> Proxy x -> () ti9 _ _ = () - - diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 8b8155d186..a6cb78a3cd 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -421,3 +421,4 @@ test('MutRec', normal, compile, ['']) test('T8856', normal, compile, ['']) test('T9117', normal, compile, ['']) test('T9117_2', expect_broken('9117'), compile, ['']) +test('T9708', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_compile/tc231.hs b/testsuite/tests/typecheck/should_compile/tc231.hs index a7270ef769..7039ffcc66 100644 --- a/testsuite/tests/typecheck/should_compile/tc231.hs +++ b/testsuite/tests/typecheck/should_compile/tc231.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -ddump-types #-} +{-# OPTIONS_GHC -ddump-types -dsuppress-module-prefixes #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-} -- See Trac #1456 diff --git a/testsuite/tests/typecheck/should_compile/tc231.stderr b/testsuite/tests/typecheck/should_compile/tc231.stderr index 46395c4866..098fe94a0c 100644 --- a/testsuite/tests/typecheck/should_compile/tc231.stderr +++ b/testsuite/tests/typecheck/should_compile/tc231.stderr @@ -1,19 +1,19 @@ -TYPE SIGNATURES - foo :: - forall s b chain. - Zork s (Z [Char]) b => - Q s (Z [Char]) chain -> ST s () - s :: forall t t1. Q t (Z [Char]) t1 -> Q t (Z [Char]) t1 -TYPE CONSTRUCTORS - data Q s a chain = Node s a chain - Promotable - data Z a = Z a - Promotable - class Zork s a b | a -> b where - huh :: Q s a chain -> ST s () -COERCION AXIOMS - axiom ShouldCompile.NTCo:Zork :: - Zork s a b = forall chain. Q s a chain -> ST s () -Dependent modules: [] -Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0, - integer-gmp-0.5.1.0] +TYPE SIGNATURES
+ foo ::
+ forall s b chain.
+ Zork s (Z [Char]) b =>
+ Q s (Z [Char]) chain -> ST s ()
+ s :: forall t t1. Q t (Z [Char]) t1 -> Q t (Z [Char]) t1
+TYPE CONSTRUCTORS
+ data Q s a chain = Node s a chain
+ Promotable
+ data Z a = Z a
+ Promotable
+ class Zork s a b | a -> b where
+ huh :: Q s a chain -> ST s ()
+COERCION AXIOMS
+ axiom NTCo:Zork ::
+ Zork s a b = forall chain. Q s a chain -> ST s ()
+Dependent modules: []
+Dependent packages: [base-4.8.0.0, ghc-prim-0.3.1.0,
+ integer-gmp-0.5.1.0]
diff --git a/testsuite/tests/typecheck/should_fail/ContextStack2.hs b/testsuite/tests/typecheck/should_fail/ContextStack2.hs index 5c50b02847..71d22c3241 100644 --- a/testsuite/tests/typecheck/should_fail/ContextStack2.hs +++ b/testsuite/tests/typecheck/should_fail/ContextStack2.hs @@ -7,3 +7,47 @@ type instance TF (a,b) = (TF a, TF b) t :: (a ~ TF (a,Int)) => Int t = undefined + +{- a ~ TF (a,Int) + ~ (TF a, TF Int) + ~ (TF (TF (a,Int)), TF Int) + ~ (TF (TF a, TF Int), TF Int) + ~ ((TF (TF a), TF (TF Int)), TF Int) + + + fsk ~ a + TF (a, Int) ~ fsk +--> + fsk ~ a +* fsk ~ (TF a, TF Int) + (flatten lhs) + a ~ (TF a, TF Int) + (flaten rhs) + a ~ (fsk1, TF Int) +(wk) TF a ~ fsk1 + +--> (rewrite inert) + + fsk ~ (fsk1, TF Int) + a ~ (fsk1, TF Int) +(wk) TF a ~ fsk1 + +--> + fsk ~ (fsk1, TF Int) + a ~ (fsk1, TF Int) + +* TF (fsk1, fsk2) ~ fsk1 +(wk) TF Tnt ~ fsk2 + +--> + fsk ~ (fsk1, TF Int) + a ~ (fsk1, TF Int) + +* fsk1 ~ (TF fsk1, TF fsk2) + (flatten rhs) + fsk1 ~ (fsk3, TF fsk2) + + +(wk) TF Int ~ fsk2 + TF fsk1 ~ fsk3 +-}
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/ContextStack2.stderr b/testsuite/tests/typecheck/should_fail/ContextStack2.stderr index 746cf15d0c..fbbd5980bc 100644 --- a/testsuite/tests/typecheck/should_fail/ContextStack2.stderr +++ b/testsuite/tests/typecheck/should_fail/ContextStack2.stderr @@ -2,8 +2,8 @@ ContextStack2.hs:8:6: Type function application stack overflow; size = 11 Use -ftype-function-depth=N to increase stack size to N - (TF (TF (TF (TF (TF (TF (TF (TF (TF (TF (TF a)))))))))), - TF (TF (TF (TF (TF (TF (TF (TF (TF (TF (TF Int))))))))))) - ~ TF (TF (TF (TF (TF (TF (TF (TF (TF (TF a))))))))) + TF (TF (TF (TF (TF (TF (TF (TF (TF (TF a))))))))) + ~ (TF (TF (TF (TF (TF (TF (TF (TF (TF (TF (TF a)))))))))), + TF (TF (TF (TF (TF (TF (TF (TF (TF (TF (TF Int))))))))))) In the ambiguity check for: forall a. (a ~ TF (a, Int)) => Int In the type signature for ‘t’: t :: (a ~ TF (a, Int)) => Int diff --git a/testsuite/tests/typecheck/should_fail/FDsFromGivens.stderr b/testsuite/tests/typecheck/should_fail/FDsFromGivens.stderr index f3320d0d8e..895cc7df01 100644 --- a/testsuite/tests/typecheck/should_fail/FDsFromGivens.stderr +++ b/testsuite/tests/typecheck/should_fail/FDsFromGivens.stderr @@ -1,12 +1,14 @@ - -FDsFromGivens.hs:21:15: - Couldn't match type ‘Char’ with ‘[a0]’ - arising from a functional dependency between constraints: - ‘C Char [a0]’ arising from a use of ‘f’ at FDsFromGivens.hs:21:15 - ‘C Char Char’ - arising from a pattern with constructor - KCC :: C Char Char => () -> KCC, - in an equation for ‘bar’ - at FDsFromGivens.hs:21:6-10 - In the expression: f - In an equation for ‘bar’: bar (KCC _) = f +
+FDsFromGivens.hs:21:15:
+ Couldn't match type ‘Char’ with ‘[a]’
+ arising from a functional dependency between constraints:
+ ‘C Char [a]’ arising from a use of ‘f’ at FDsFromGivens.hs:21:15
+ ‘C Char Char’
+ arising from a pattern with constructor
+ KCC :: C Char Char => () -> KCC,
+ in an equation for ‘bar’
+ at FDsFromGivens.hs:21:6-10
+ Relevant bindings include
+ bar :: KCC -> a -> a (bound at FDsFromGivens.hs:21:1)
+ In the expression: f
+ In an equation for ‘bar’: bar (KCC _) = f
diff --git a/testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr b/testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr index 80ab8d83f6..d8bec07269 100644 --- a/testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr +++ b/testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr @@ -19,7 +19,7 @@ FrozenErrorTests.hs:26:9: In an equation for ‘test1’: test1 = goo1 False undefined FrozenErrorTests.hs:29:15: - Couldn't match type ‘Int’ with ‘[Int]’ + Couldn't match type ‘[Int]’ with ‘Int’ Expected type: [[Int]] Actual type: F [Int] Bool In the first argument of ‘goo2’, namely ‘(goo1 False undefined)’ @@ -27,7 +27,7 @@ FrozenErrorTests.hs:29:15: In an equation for ‘test2’: test2 = goo2 (goo1 False undefined) FrozenErrorTests.hs:30:9: - Couldn't match type ‘[Int]’ with ‘Int’ + Couldn't match type ‘Int’ with ‘[Int]’ Expected type: [[Int]] Actual type: F [Int] Bool In the expression: goo1 False (goo2 undefined) diff --git a/testsuite/tests/typecheck/should_fail/T1899.stderr b/testsuite/tests/typecheck/should_fail/T1899.stderr index a8baba78cc..324eebbc9a 100644 --- a/testsuite/tests/typecheck/should_fail/T1899.stderr +++ b/testsuite/tests/typecheck/should_fail/T1899.stderr @@ -1,11 +1,13 @@ -T1899.hs:12:29: - Couldn't match expected type ‘a’ with actual type ‘Proposition a0’ +T1899.hs:14:36: + Couldn't match type ‘a’ with ‘Proposition a1’ ‘a’ is a rigid type variable bound by the type signature for transRHS :: [a] -> Int -> Constraint a at T1899.hs:9:14 + Expected type: [Proposition a1] + Actual type: [a] Relevant bindings include varSet :: [a] (bound at T1899.hs:10:11) transRHS :: [a] -> Int -> Constraint a (bound at T1899.hs:10:2) - In the first argument of ‘Prop’, namely ‘(Auxiliary undefined)’ - In the expression: Prop (Auxiliary undefined) + In the first argument of ‘Auxiliary’, namely ‘varSet’ + In the first argument of ‘Prop’, namely ‘(Auxiliary varSet)’ diff --git a/testsuite/tests/typecheck/should_fail/T2688.stderr b/testsuite/tests/typecheck/should_fail/T2688.stderr index b117f02f9f..4b28d7da31 100644 --- a/testsuite/tests/typecheck/should_fail/T2688.stderr +++ b/testsuite/tests/typecheck/should_fail/T2688.stderr @@ -1,9 +1,6 @@ T2688.hs:8:22: - Could not deduce (s ~ v) - from the context (VectorSpace v s) - bound by the class declaration for ‘VectorSpace’ - at T2688.hs:(5,1)-(8,23) + Couldn't match expected type ‘v’ with actual type ‘s’ ‘s’ is a rigid type variable bound by the class declaration for ‘VectorSpace’ at T2688.hs:5:21 ‘v’ is a rigid type variable bound by diff --git a/testsuite/tests/typecheck/should_fail/T5236.stderr b/testsuite/tests/typecheck/should_fail/T5236.stderr index 8a723bab9b..e1e136a249 100644 --- a/testsuite/tests/typecheck/should_fail/T5236.stderr +++ b/testsuite/tests/typecheck/should_fail/T5236.stderr @@ -1,10 +1,10 @@ - -T5236.hs:13:9: - Couldn't match type ‘A’ with ‘B’ - arising from a functional dependency between: - constraint ‘Id A B’ - arising from the type signature for loop :: Id A B => Bool - instance ‘Id A A’ at T5236.hs:10:10-15 - In the ambiguity check for: Id A B => Bool - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘loop’: loop :: Id A B => Bool +
+T5236.hs:13:9:
+ Couldn't match type ‘B’ with ‘A’
+ arising from a functional dependency between:
+ constraint ‘Id A B’
+ arising from the type signature for loop :: Id A B => Bool
+ instance ‘Id B B’ at T5236.hs:11:10-15
+ In the ambiguity check for: Id A B => Bool
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the type signature for ‘loop’: loop :: Id A B => Bool
diff --git a/testsuite/tests/typecheck/should_fail/T5300.stderr b/testsuite/tests/typecheck/should_fail/T5300.stderr index c94f11531f..912cd19842 100644 --- a/testsuite/tests/typecheck/should_fail/T5300.stderr +++ b/testsuite/tests/typecheck/should_fail/T5300.stderr @@ -16,14 +16,14 @@ T5300.hs:11:7: f1 :: (Monad m, C1 a b c) => a -> StateT (T b) m a T5300.hs:14:7: - Could not deduce (C1 a1 b1 c10) + Could not deduce (C2 a2 b2 c20) arising from the ambiguity check for ‘f2’ from the context (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) bound by the type signature for f2 :: (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) => a1 -> StateT (T b2) m a2 at T5300.hs:14:7-69 - The type variable ‘c10’ is ambiguous + The type variable ‘c20’ is ambiguous In the ambiguity check for: forall a1 b2 (m :: * -> *) a2 b1 c1 c2. (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) => diff --git a/testsuite/tests/typecheck/should_fail/T5684.stderr b/testsuite/tests/typecheck/should_fail/T5684.stderr index 56b0800351..b2d0b01c46 100644 --- a/testsuite/tests/typecheck/should_fail/T5684.stderr +++ b/testsuite/tests/typecheck/should_fail/T5684.stderr @@ -1,30 +1,94 @@ +T5684.hs:20:12: + No instance for (A Bool) arising from a use of ‘op’ + In the expression: op False False + In the expression: + [op False False, op 'c' undefined, op True undefined] + In an equation for ‘flop1’: + flop1 = [op False False, op 'c' undefined, op True undefined] + +T5684.hs:24:12: + No instance for (B Char b10) arising from a use of ‘op’ + In the expression: op 'c' undefined + In the expression: + [op False False, op 'c' undefined, op True undefined] + In an equation for ‘flop1’: + flop1 = [op False False, op 'c' undefined, op True undefined] + T5684.hs:25:12: - No instance for (A b6) arising from a use of ‘op’ + No instance for (A b11) arising from a use of ‘op’ In the expression: op True undefined In the expression: [op False False, op 'c' undefined, op True undefined] In an equation for ‘flop1’: flop1 = [op False False, op 'c' undefined, op True undefined] +T5684.hs:29:12: + No instance for (A Bool) arising from a use of ‘op’ + In the expression: op False False + In the expression: + [op False False, op True undefined, op 'c' undefined] + In an equation for ‘flop2’: + flop2 = [op False False, op True undefined, op 'c' undefined] + T5684.hs:30:12: - No instance for (A b5) arising from a use of ‘op’ + No instance for (A b8) arising from a use of ‘op’ In the expression: op True undefined In the expression: [op False False, op True undefined, op 'c' undefined] In an equation for ‘flop2’: flop2 = [op False False, op True undefined, op 'c' undefined] +T5684.hs:31:12: + No instance for (B Char b9) arising from a use of ‘op’ + In the expression: op 'c' undefined + In the expression: + [op False False, op True undefined, op 'c' undefined] + In an equation for ‘flop2’: + flop2 = [op False False, op True undefined, op 'c' undefined] + +T5684.hs:35:12: + No instance for (B Char b6) arising from a use of ‘op’ + In the expression: op 'c' undefined + In the expression: + [op 'c' undefined, op True undefined, op False False] + In an equation for ‘flop3’: + flop3 = [op 'c' undefined, op True undefined, op False False] + T5684.hs:36:12: - No instance for (A b4) arising from a use of ‘op’ + No instance for (A b7) arising from a use of ‘op’ In the expression: op True undefined In the expression: [op 'c' undefined, op True undefined, op False False] In an equation for ‘flop3’: flop3 = [op 'c' undefined, op True undefined, op False False] +T5684.hs:37:12: + No instance for (A Bool) arising from a use of ‘op’ + In the expression: op False False + In the expression: + [op 'c' undefined, op True undefined, op False False] + In an equation for ‘flop3’: + flop3 = [op 'c' undefined, op True undefined, op False False] + +T5684.hs:40:12: + No instance for (B Char b4) arising from a use of ‘op’ + In the expression: op 'c' undefined + In the expression: + [op 'c' undefined, op False False, op True undefined] + In an equation for ‘flop4’: + flop4 = [op 'c' undefined, op False False, op True undefined] + +T5684.hs:41:12: + No instance for (A Bool) arising from a use of ‘op’ + In the expression: op False False + In the expression: + [op 'c' undefined, op False False, op True undefined] + In an equation for ‘flop4’: + flop4 = [op 'c' undefined, op False False, op True undefined] + T5684.hs:42:12: - No instance for (A b3) arising from a use of ‘op’ + No instance for (A b5) arising from a use of ‘op’ In the expression: op True undefined In the expression: [op 'c' undefined, op False False, op True undefined] @@ -39,6 +103,22 @@ T5684.hs:46:12: In an equation for ‘flop5’: flop5 = [op True undefined, op 'c' undefined, op False False] +T5684.hs:47:12: + No instance for (B Char b3) arising from a use of ‘op’ + In the expression: op 'c' undefined + In the expression: + [op True undefined, op 'c' undefined, op False False] + In an equation for ‘flop5’: + flop5 = [op True undefined, op 'c' undefined, op False False] + +T5684.hs:48:12: + No instance for (A Bool) arising from a use of ‘op’ + In the expression: op False False + In the expression: + [op True undefined, op 'c' undefined, op False False] + In an equation for ‘flop5’: + flop5 = [op True undefined, op 'c' undefined, op False False] + T5684.hs:52:12: No instance for (A b0) arising from a use of ‘op’ In the expression: op True undefined diff --git a/testsuite/tests/typecheck/should_fail/T5853.stderr b/testsuite/tests/typecheck/should_fail/T5853.stderr index 997ce196c3..63868d0a3b 100644 --- a/testsuite/tests/typecheck/should_fail/T5853.stderr +++ b/testsuite/tests/typecheck/should_fail/T5853.stderr @@ -1,6 +1,6 @@ T5853.hs:15:52: - Could not deduce (Subst (Subst fa a) b ~ Subst fa b) + Could not deduce (Subst (Subst fa b) a ~ Subst fa a) from the context (F fa, Elem (Subst fa b) ~ b, Subst (Subst fa b) (Elem fa) ~ fa, diff --git a/testsuite/tests/typecheck/should_fail/T7748a.stderr b/testsuite/tests/typecheck/should_fail/T7748a.stderr index de451eb52f..63cff4aa17 100644 --- a/testsuite/tests/typecheck/should_fail/T7748a.stderr +++ b/testsuite/tests/typecheck/should_fail/T7748a.stderr @@ -1,15 +1,18 @@ - -T7748a.hs:14:24: - Couldn't match expected type ‘a’ with actual type ‘Maybe t0’ - ‘a’ is a rigid type variable bound by - the type signature for test :: a -> r -> () at T7748a.hs:11:9 - Relevant bindings include - zd :: a (bound at T7748a.hs:12:6) - test :: a -> r -> () (bound at T7748a.hs:12:1) - In the pattern: Nothing - In a case alternative: Nothing -> const () - In the expression: - case zd of { - Nothing -> const () - Just Nothing -> const () - Just (Just p) -> p } +
+T7748a.hs:16:24:
+ Couldn't match expected type ‘a’
+ with actual type ‘Maybe (Maybe (r -> ()))’
+ ‘a’ is a rigid type variable bound by
+ the type signature for test :: a -> r -> () at T7748a.hs:11:9
+ Relevant bindings include
+ g :: r -> () (bound at T7748a.hs:13:16)
+ f :: r -> () (bound at T7748a.hs:13:8)
+ zd :: a (bound at T7748a.hs:12:6)
+ test :: a -> r -> () (bound at T7748a.hs:12:1)
+ In the pattern: Just (Just p)
+ In a case alternative: Just (Just p) -> p
+ In the expression:
+ case zd of {
+ Nothing -> const ()
+ Just Nothing -> const ()
+ Just (Just p) -> p }
diff --git a/testsuite/tests/typecheck/should_fail/T8142.stderr b/testsuite/tests/typecheck/should_fail/T8142.stderr index d585abdcd2..a084f7afcc 100644 --- a/testsuite/tests/typecheck/should_fail/T8142.stderr +++ b/testsuite/tests/typecheck/should_fail/T8142.stderr @@ -1,28 +1,10 @@ -
-T8142.hs:6:18:
- Couldn't match type ‘Nu ((,) t0)’ with ‘Nu ((,) t)’
- NB: ‘Nu’ is a type function, and may not be injective
- The type variable ‘t0’ is ambiguous
- Expected type: Nu ((,) t) -> Nu f
- Actual type: Nu ((,) t0) -> Nu f0
- When checking that ‘h’ has the inferred type
- h :: forall t (f :: * -> *). Nu ((,) t) -> Nu f
- Probable cause: the inferred type is ambiguous
- In an equation for ‘tracer’:
- tracer
- = h
- where
- h = (\ (_, b) -> ((outI . fmap h) b)) . out
-
-T8142.hs:6:57:
- Could not deduce (Nu ((,) t) ~ f1 (Nu ((,) t)))
- from the context (Functor f, Coinductive f)
- bound by the type signature for
- tracer :: (Functor f, Coinductive f) => (c -> f c) -> c -> f c
- at T8142.hs:5:11-64
- Expected type: Nu ((,) t) -> (t, f1 (Nu ((,) t)))
- Actual type: Nu ((,) t) -> (t, Nu ((,) t))
- Relevant bindings include
- h :: Nu ((,) t) -> Nu f1 (bound at T8142.hs:6:18)
- In the second argument of ‘(.)’, namely ‘out’
- In the expression: (\ (_, b) -> ((outI . fmap h) b)) . out
+ +T8142.hs:6:57: + Couldn't match type ‘Nu ((,) t0)’ with ‘g0 (Nu ((,) t0))’ + The type variables ‘t0’, ‘g0’ are ambiguous + Expected type: Nu ((,) t0) -> (t0, g0 (Nu ((,) t0))) + Actual type: Nu ((,) t0) -> (t0, Nu ((,) t0)) + Relevant bindings include + h :: Nu ((,) t0) -> Nu g0 (bound at T8142.hs:6:18) + In the second argument of ‘(.)’, namely ‘out’ + In the expression: (\ (_, b) -> ((outI . fmap h) b)) . out diff --git a/testsuite/tests/typecheck/should_fail/T8450.hs b/testsuite/tests/typecheck/should_fail/T8450.hs index ac122e7bc7..92b5b67994 100644 --- a/testsuite/tests/typecheck/should_fail/T8450.hs +++ b/testsuite/tests/typecheck/should_fail/T8450.hs @@ -6,3 +6,6 @@ runEffect = undefined run :: forall a. a run = runEffect $ (undefined :: Either a ()) + +{- Either a () ~ Either Bool alpha + a ~ alpha -}
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/T8450.stderr b/testsuite/tests/typecheck/should_fail/T8450.stderr index ef3c62e7b6..2cc9a6b7ab 100644 --- a/testsuite/tests/typecheck/should_fail/T8450.stderr +++ b/testsuite/tests/typecheck/should_fail/T8450.stderr @@ -1,13 +1,9 @@ - -T8450.hs:8:20: - Couldn't match type ‘a’ with ‘Bool’ - ‘a’ is a rigid type variable bound by - the type signature for run :: a at T8450.hs:7:15 - Expected type: Either Bool () - Actual type: Either a () - Relevant bindings include run :: a (bound at T8450.hs:8:1) - In the second argument of ‘($)’, namely - ‘(undefined :: Either a ())’ - In the expression: runEffect $ (undefined :: Either a ()) - In an equation for ‘run’: - run = runEffect $ (undefined :: Either a ()) +
+T8450.hs:8:7:
+ Couldn't match expected type ‘a’ with actual type ‘()’
+ ‘a’ is a rigid type variable bound by
+ the type signature for run :: a at T8450.hs:7:15
+ Relevant bindings include run :: a (bound at T8450.hs:8:1)
+ In the expression: runEffect $ (undefined :: Either a ())
+ In an equation for ‘run’:
+ run = runEffect $ (undefined :: Either a ())
diff --git a/testsuite/tests/typecheck/should_fail/T8883.stderr b/testsuite/tests/typecheck/should_fail/T8883.stderr index d02f02338e..28730ae9c7 100644 --- a/testsuite/tests/typecheck/should_fail/T8883.stderr +++ b/testsuite/tests/typecheck/should_fail/T8883.stderr @@ -1,8 +1,8 @@ -
-T8883.hs:20:1:
- Non type-variable argument in the constraint: Functor (PF a)
- (Use FlexibleContexts to permit this)
- When checking that ‘fold’ has the inferred type
- fold :: forall a b.
- (Regular a, Functor (PF a)) =>
- (PF a b -> b) -> a -> b
+ +T8883.hs:20:1: + Non type-variable argument in the constraint: Functor (PF a) + (Use FlexibleContexts to permit this) + When checking that ‘fold’ has the inferred type + fold :: forall a b. + (Functor (PF a), Regular a) => + (PF a b -> b) -> a -> b diff --git a/testsuite/tests/typecheck/should_fail/T9305.stderr b/testsuite/tests/typecheck/should_fail/T9305.stderr index 16104237b9..c908a562ae 100644 --- a/testsuite/tests/typecheck/should_fail/T9305.stderr +++ b/testsuite/tests/typecheck/should_fail/T9305.stderr @@ -1,6 +1,6 @@ T9305.hs:8:48: - No instance for (Functor Event) + No instance for (Functor F) arising from the first field of ‘EventF’ (type ‘F (Event a)’) Possible fix: use a standalone 'deriving instance' declaration, diff --git a/testsuite/tests/typecheck/should_fail/T9739.hs b/testsuite/tests/typecheck/should_fail/T9739.hs new file mode 100644 index 0000000000..18df797100 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T9739.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +module T9739 where + +class Class3 a => Class1 a where + +class Class2 t a where + class2 :: (Class3 t) => a -> m + +class (Class1 t, Class2 t t) => Class3 t where diff --git a/testsuite/tests/typecheck/should_fail/T9739.stderr b/testsuite/tests/typecheck/should_fail/T9739.stderr new file mode 100644 index 0000000000..34e2f114f8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T9739.stderr @@ -0,0 +1,10 @@ + +T9739.hs:4:1: + Cycle in class declaration (via superclasses): + Class1 -> Class3 -> Class1 + In the class declaration for ‘Class1’ + +T9739.hs:9:1: + Cycle in class declaration (via superclasses): + Class3 -> Class1 -> Class3 + In the class declaration for ‘Class3’ diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 2738e81fff..e9dd2890bf 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -341,3 +341,4 @@ test('T9323', normal, compile_fail, ['']) test('T9415', normal, compile_fail, ['']) test('T9612', normal, compile_fail, ['']) test('T9634', normal, compile_fail, ['']) +test('T9739', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/mc21.stderr b/testsuite/tests/typecheck/should_fail/mc21.stderr index 2305394260..e3a8b882c8 100644 --- a/testsuite/tests/typecheck/should_fail/mc21.stderr +++ b/testsuite/tests/typecheck/should_fail/mc21.stderr @@ -1,9 +1,9 @@ - -mc21.hs:12:26: - Couldn't match type ‘a’ with ‘[a]’ - ‘a’ is a rigid type variable bound by - a type expected by the context: [a] -> t [a] at mc21.hs:12:9 - Expected type: [a] -> t [a] - Actual type: [a] -> [a] - In the expression: take 5 - In a stmt of a monad comprehension: then group using take 5 +
+mc21.hs:12:26:
+ Couldn't match type ‘a’ with ‘[a]’
+ ‘a’ is a rigid type variable bound by
+ a type expected by the context: [a] -> [[a]] at mc21.hs:12:9
+ Expected type: [a] -> [[a]]
+ Actual type: [a] -> [a]
+ In the expression: take 5
+ In a stmt of a monad comprehension: then group using take 5
diff --git a/testsuite/tests/typecheck/should_fail/mc22.stderr b/testsuite/tests/typecheck/should_fail/mc22.stderr index 44a2eebdc7..104bcffe4c 100644 --- a/testsuite/tests/typecheck/should_fail/mc22.stderr +++ b/testsuite/tests/typecheck/should_fail/mc22.stderr @@ -1,22 +1,21 @@ - -mc22.hs:10:9: - No instance for (Functor t1) arising from a use of ‘fmap’ - Possible fix: - add (Functor t1) to the context of - a type expected by the context: (a -> b) -> t1 a -> t1 b - or the inferred type of foo :: t (t1 [Char]) - In the expression: fmap - In a stmt of a monad comprehension: then group using take 5 - In the expression: - [x + 1 | x <- ["Hello", "World"], then group using take 5] - -mc22.hs:10:26: - Couldn't match type ‘a’ with ‘t1 a’ - ‘a’ is a rigid type variable bound by - a type expected by the context: [a] -> t (t1 a) at mc22.hs:10:9 - Expected type: [a] -> t (t1 a) - Actual type: [a] -> [a] - Relevant bindings include - foo :: t (t1 [Char]) (bound at mc22.hs:8:1) - In the expression: take 5 - In a stmt of a monad comprehension: then group using take 5 +
+mc22.hs:10:9:
+ No instance for (Functor t) arising from a use of ‘fmap’
+ Possible fix:
+ add (Functor t) to the context of
+ a type expected by the context: (a -> b) -> t a -> t b
+ or the inferred type of foo :: [t [Char]]
+ In the expression: fmap
+ In a stmt of a monad comprehension: then group using take 5
+ In the expression:
+ [x + 1 | x <- ["Hello", "World"], then group using take 5]
+
+mc22.hs:10:26:
+ Couldn't match type ‘a’ with ‘t a’
+ ‘a’ is a rigid type variable bound by
+ a type expected by the context: [a] -> [t a] at mc22.hs:10:9
+ Expected type: [a] -> [t a]
+ Actual type: [a] -> [a]
+ Relevant bindings include foo :: [t [Char]] (bound at mc22.hs:8:1)
+ In the expression: take 5
+ In a stmt of a monad comprehension: then group using take 5
diff --git a/testsuite/tests/typecheck/should_fail/mc25.stderr b/testsuite/tests/typecheck/should_fail/mc25.stderr index e101f4b328..e145af4339 100644 --- a/testsuite/tests/typecheck/should_fail/mc25.stderr +++ b/testsuite/tests/typecheck/should_fail/mc25.stderr @@ -1,18 +1,18 @@ - -mc25.hs:9:24: - No instance for (Functor t2) arising from a use of ‘fmap’ - Possible fix: - add (Functor t2) to the context of - a type expected by the context: (a -> b) -> t2 a -> t2 b - or the inferred type of z :: t (t2 t1) - In the expression: fmap - In a stmt of a monad comprehension: then group by x using take - In the expression: [x | x <- [1 .. 10], then group by x using take] - -mc25.hs:9:46: - Couldn't match type ‘Int’ with ‘a -> t1’ - Expected type: (a -> t1) -> [a] -> t (t2 a) - Actual type: Int -> [a] -> [a] - Relevant bindings include z :: t (t2 t1) (bound at mc25.hs:9:1) - In the expression: take - In a stmt of a monad comprehension: then group by x using take +
+mc25.hs:9:24:
+ No instance for (Functor t1) arising from a use of ‘fmap’
+ Possible fix:
+ add (Functor t1) to the context of
+ a type expected by the context: (a -> b) -> t1 a -> t1 b
+ or the inferred type of z :: [t1 t]
+ In the expression: fmap
+ In a stmt of a monad comprehension: then group by x using take
+ In the expression: [x | x <- [1 .. 10], then group by x using take]
+
+mc25.hs:9:46:
+ Couldn't match type ‘Int’ with ‘a -> t’
+ Expected type: (a -> t) -> [a] -> [t1 a]
+ Actual type: Int -> [a] -> [a]
+ Relevant bindings include z :: [t1 t] (bound at mc25.hs:9:1)
+ In the expression: take
+ In a stmt of a monad comprehension: then group by x using take
diff --git a/testsuite/tests/typecheck/should_fail/tcfail019.stderr b/testsuite/tests/typecheck/should_fail/tcfail019.stderr index 49eb857593..70b38be257 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail019.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail019.stderr @@ -1,5 +1,5 @@ tcfail019.hs:18:10: - No instance for (B [a]) + No instance for (C [a]) arising from the superclasses of an instance declaration In the instance declaration for ‘D [a]’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail067.stderr b/testsuite/tests/typecheck/should_fail/tcfail067.stderr index e3f6444572..fb6d6707fb 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail067.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail067.stderr @@ -34,11 +34,11 @@ tcfail067.hs:46:12: = show value ++ " :" ++ show lower ++ ".." ++ show upper tcfail067.hs:61:12: - Could not deduce (Show a) arising from a use of ‘numSubRangeNegate’ + Could not deduce (Ord a) arising from a use of ‘numSubRangeNegate’ from the context (Num a) bound by the instance declaration at tcfail067.hs:60:10-34 Possible fix: - add (Show a) to the context of the instance declaration + add (Ord a) to the context of the instance declaration In the expression: numSubRangeNegate In an equation for ‘negate’: negate = numSubRangeNegate In the instance declaration for ‘Num (SubRange a)’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail068.hs b/testsuite/tests/typecheck/should_fail/tcfail068.hs index beae0f8359..40dc0e0bd8 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail068.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail068.hs @@ -21,7 +21,7 @@ itiap i f arr = return arr) itrap :: Constructed a => ((Int,Int),(Int,Int)) -> (a->a) -> IndTree s a -> IndTree s a -itrap ((i,k),(j,l)) f arr = runST(itrap' i k) +itrap ((i,k),(j,l)) f arr = runST (itrap' i k) where itrap' i k = if k > l then return arr else (itrapsnd i k >> diff --git a/testsuite/tests/typecheck/should_fail/tcfail068.stderr b/testsuite/tests/typecheck/should_fail/tcfail068.stderr index 1df6fb8bb4..233c92e6ae 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail068.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail068.stderr @@ -1,10 +1,6 @@ tcfail068.hs:14:9: - Could not deduce (s1 ~ s) - from the context (Constructed a) - bound by the type signature for - itgen :: Constructed a => (Int, Int) -> a -> IndTree s a - at tcfail068.hs:11:10-55 + Couldn't match type ‘s1’ with ‘s’ ‘s1’ is a rigid type variable bound by a type expected by the context: GHC.ST.ST s1 (IndTree s a) at tcfail068.hs:13:9 @@ -22,12 +18,7 @@ tcfail068.hs:14:9: In the expression: runST (newSTArray ((1, 1), n) x) tcfail068.hs:19:21: - Could not deduce (s ~ s1) - from the context (Constructed a) - bound by the type signature for - itiap :: Constructed a => - (Int, Int) -> (a -> a) -> IndTree s a -> IndTree s a - at tcfail068.hs:16:10-75 + Couldn't match type ‘s’ with ‘s1’ ‘s’ is a rigid type variable bound by the type signature for itiap :: Constructed a => @@ -45,13 +36,8 @@ tcfail068.hs:19:21: In the first argument of ‘readSTArray’, namely ‘arr’ In the first argument of ‘(>>=)’, namely ‘readSTArray arr i’ -tcfail068.hs:24:35: - Could not deduce (s ~ s1) - from the context (Constructed a) - bound by the type signature for - itrap :: Constructed a => - ((Int, Int), (Int, Int)) -> (a -> a) -> IndTree s a -> IndTree s a - at tcfail068.hs:23:10-87 +tcfail068.hs:24:36: + Couldn't match type ‘s’ with ‘s1’ ‘s’ is a rigid type variable bound by the type signature for itrap :: Constructed a => @@ -75,18 +61,7 @@ tcfail068.hs:24:35: In the expression: runST (itrap' i k) tcfail068.hs:36:46: - Could not deduce (s ~ s1) - from the context (Constructed b) - bound by the type signature for - itrapstate :: Constructed b => - ((Int, Int), (Int, Int)) - -> (a -> b -> (a, b)) - -> ((Int, Int) -> c -> a) - -> (a -> c) - -> c - -> IndTree s b - -> (c, IndTree s b) - at tcfail068.hs:(34,15)-(35,62) + Couldn't match type ‘s’ with ‘s1’ ‘s’ is a rigid type variable bound by the type signature for itrapstate :: Constructed b => diff --git a/testsuite/tests/typecheck/should_fail/tcfail072.stderr b/testsuite/tests/typecheck/should_fail/tcfail072.stderr index 64486c1cb0..d5eb4aa87f 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail072.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail072.stderr @@ -1,11 +1,11 @@ tcfail072.hs:23:13: - Could not deduce (Ord q0) arising from a use of ‘g’ + Could not deduce (Ord p0) arising from a use of ‘g’ from the context (Ord p, Ord q) bound by the type signature for g :: (Ord p, Ord q) => AB p q -> Bool at tcfail072.hs:22:6-38 - The type variable ‘q0’ is ambiguous + The type variable ‘p0’ is ambiguous Note: there are several potential instances: instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’ instance Ord () -- Defined in ‘GHC.Classes’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail131.stderr b/testsuite/tests/typecheck/should_fail/tcfail131.stderr index 41e8af681f..f49a4b3975 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail131.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail131.stderr @@ -1,9 +1,6 @@ tcfail131.hs:7:9: - Could not deduce (b ~ Integer) - from the context (Num b) - bound by the type signature for g :: Num b => b -> b - at tcfail131.hs:6:8-22 + Couldn't match expected type ‘b’ with actual type ‘Integer’ ‘b’ is a rigid type variable bound by the type signature for g :: Num b => b -> b at tcfail131.hs:6:8 Relevant bindings include diff --git a/testsuite/tests/typecheck/should_fail/tcfail143.stderr b/testsuite/tests/typecheck/should_fail/tcfail143.stderr index b36d7a8b37..04e7ec8d14 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail143.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail143.stderr @@ -1,8 +1,8 @@ - -tcfail143.hs:29:9: - Couldn't match type ‘S Z’ with ‘Z’ - arising from a functional dependency between: - constraint ‘MinMax (S Z) Z Z Z’ arising from a use of ‘extend’ - instance ‘MinMax a Z Z a’ at tcfail143.hs:11:10-23 - In the expression: n1 `extend` n0 - In an equation for ‘t2’: t2 = n1 `extend` n0 +
+tcfail143.hs:29:9:
+ Couldn't match type ‘Z’ with ‘S Z’
+ arising from a functional dependency between:
+ constraint ‘MinMax (S Z) Z Z Z’ arising from a use of ‘extend’
+ instance ‘MinMax Z b Z b’ at tcfail143.hs:12:10-23
+ In the expression: n1 `extend` n0
+ In an equation for ‘t2’: t2 = n1 `extend` n0
diff --git a/testsuite/tests/typecheck/should_fail/tcfail171.stderr b/testsuite/tests/typecheck/should_fail/tcfail171.stderr index 849ce3aa10..d29f91ef05 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail171.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail171.stderr @@ -1,8 +1,8 @@ tcfail171.hs:9:10: - No instance for (PrintfArg a) arising from a use of ‘printf’ + No instance for (PrintfType b) arising from a use of ‘printf’ Possible fix: - add (PrintfArg a) to the context of + add (PrintfType b) to the context of the type signature for phex :: a -> b In the expression: printf "0x%x" x In an equation for ‘phex’: phex x = printf "0x%x" x diff --git a/testsuite/tests/typecheck/should_fail/tcfail186.stderr b/testsuite/tests/typecheck/should_fail/tcfail186.stderr index 1842628e40..bf74d8182c 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail186.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail186.stderr @@ -1,8 +1,8 @@ - -tcfail186.hs:7:9: - Couldn't match type ‘[Char]’ with ‘Int’ - Expected type: PhantomSyn a0 - Actual type: [Char] - In the first argument of ‘f’, namely ‘"hoo"’ - In the expression: f "hoo" - In an equation for ‘foo’: foo = f "hoo" +
+tcfail186.hs:7:9:
+ Couldn't match type ‘[Char]’ with ‘Int’
+ Expected type: PhantomSyn a0
+ Actual type: [Char]
+ In the first argument of ‘f’, namely ‘"hoo"’
+ In the expression: f "hoo"
+ In an equation for ‘foo’: foo = f "hoo"
diff --git a/testsuite/tests/typecheck/should_fail/tcfail201.stderr b/testsuite/tests/typecheck/should_fail/tcfail201.stderr index a029e8c6d3..1270315a19 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail201.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail201.stderr @@ -1,19 +1,20 @@ - -tcfail201.hs:17:27: - Couldn't match expected type ‘a’ with actual type ‘HsDoc t0’ - ‘a’ is a rigid type variable bound by - the type signature for - gfoldl' :: (forall a1 b. c (a1 -> b) -> a1 -> c b) - -> (forall g. g -> c g) -> a -> c a - at tcfail201.hs:15:12 - Relevant bindings include - hsDoc :: a (bound at tcfail201.hs:16:13) - gfoldl' :: (forall a1 b. c (a1 -> b) -> a1 -> c b) - -> (forall g. g -> c g) -> a -> c a - (bound at tcfail201.hs:16:1) - In the pattern: DocEmpty - In a case alternative: DocEmpty -> z DocEmpty - In the expression: - case hsDoc of { - DocEmpty -> z DocEmpty - (DocParagraph hsDoc) -> z DocParagraph `k` hsDoc } +
+tcfail201.hs:18:28:
+ Couldn't match expected type ‘a’ with actual type ‘HsDoc id1’
+ ‘a’ is a rigid type variable bound by
+ the type signature for
+ gfoldl' :: (forall a1 b. c (a1 -> b) -> a1 -> c b)
+ -> (forall g. g -> c g) -> a -> c a
+ at tcfail201.hs:15:12
+ Relevant bindings include
+ hsDoc :: a (bound at tcfail201.hs:16:13)
+ gfoldl' :: (forall a1 b. c (a1 -> b) -> a1 -> c b)
+ -> (forall g. g -> c g) -> a -> c a
+ (bound at tcfail201.hs:16:1)
+ In the pattern: DocParagraph hsDoc
+ In a case alternative:
+ (DocParagraph hsDoc) -> z DocParagraph `k` hsDoc
+ In the expression:
+ case hsDoc of {
+ DocEmpty -> z DocEmpty
+ (DocParagraph hsDoc) -> z DocParagraph `k` hsDoc }
diff --git a/testsuite/tests/typecheck/should_fail/tcfail204.stderr b/testsuite/tests/typecheck/should_fail/tcfail204.stderr index 66d7269262..e8ecfc0024 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail204.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail204.stderr @@ -1,10 +1,11 @@ -tcfail204.hs:10:7: Warning: +tcfail204.hs:10:15: Warning: Defaulting the following constraint(s) to type ‘Double’ - (RealFrac a0) - arising from a use of ‘ceiling’ at tcfail204.hs:10:7-13 (Fractional a0) arising from the literal ‘6.3’ at tcfail204.hs:10:15-17 + (RealFrac a0) + arising from a use of ‘ceiling’ at tcfail204.hs:10:7-13 + In the first argument of ‘ceiling’, namely ‘6.3’ In the expression: ceiling 6.3 In an equation for ‘foo’: foo = ceiling 6.3 diff --git a/testsuite/tests/typecheck/should_run/T5751.hs b/testsuite/tests/typecheck/should_run/T5751.hs index cf1142195b..423a40736d 100644 --- a/testsuite/tests/typecheck/should_run/T5751.hs +++ b/testsuite/tests/typecheck/should_run/T5751.hs @@ -18,7 +18,7 @@ instance (MonadIO m) => (XMLGenerator (IdentityT m)) where genElement _ = liftIO $ putStrLn "in genElement" main :: IO () -main = +main = do runIdentityT web putStrLn "done." diff --git a/testsuite/tests/typecheck/should_run/tcrun036.hs b/testsuite/tests/typecheck/should_run/tcrun036.hs index 64fffb7fde..8f42d30195 100644 --- a/testsuite/tests/typecheck/should_run/tcrun036.hs +++ b/testsuite/tests/typecheck/should_run/tcrun036.hs @@ -24,10 +24,10 @@ module Main where import Prelude hiding (traverse) class Catalog c where - traverse :: c -> Viewer -> IO () + mtraverse :: c -> Viewer -> IO () instance Catalog Int where - traverse i v = viewShowable v i + mtraverse i v = viewShowable v i type View a = a -> IO () @@ -38,23 +38,23 @@ data Viewer = Viewer { printer :: Viewer --printer = Viewer { --- viewCatalog = \x -> traverse x printer, +-- viewCatalog = \x -> mtraverse x printer, -- viewShowable = putStrLn . show } printer = Viewer { viewCatalog = printCatalog, viewShowable = putStrLn . show } printCatalog :: forall c. Catalog c => View c -printCatalog x = traverse x printer +printCatalog x = mtraverse x printer data X = X { cat :: Int } instance Catalog X where - traverse x v = do + mtraverse x v = do viewCatalog v (cat x) main = do let x = X { cat = 20 } - traverse x printer + mtraverse x printer |