diff options
| author | Ian Lynagh <ian@well-typed.com> | 2012-10-03 16:10:16 +0100 |
|---|---|---|
| committer | Ian Lynagh <ian@well-typed.com> | 2012-10-03 16:10:16 +0100 |
| commit | a6b0ab269e74ca06445230a243065a0e35bc1916 (patch) | |
| tree | 5a34d9b5e4b7a5880ba80846fdc08b780d716e49 | |
| parent | 1b3f27473ce5e15392e65c1cc264e0ef86d1eade (diff) | |
| parent | 65e6470c39e9d45cbdb7834486bcae7f4a6259e6 (diff) | |
| download | haskell-a6b0ab269e74ca06445230a243065a0e35bc1916.tar.gz | |
Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc
89 files changed, 5019 insertions, 4675 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 2760156e1c..616316c7ff 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -66,6 +66,7 @@ module BasicTypes( StrictnessMark(..), isMarkedStrict, DefMethSpec(..), + SwapFlag(..), flipSwap, unSwap, CompilerPhase(..), PhaseNum, Activation(..), isActive, isActiveIn, @@ -125,6 +126,31 @@ type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). %************************************************************************ %* * + Swap flag +%* * +%************************************************************************ + +\begin{code} +data SwapFlag + = NotSwapped -- Args are: actual, expected + | IsSwapped -- Args are: expected, actual + +instance Outputable SwapFlag where + ppr IsSwapped = ptext (sLit "Is-swapped") + ppr NotSwapped = ptext (sLit "Not-swapped") + +flipSwap :: SwapFlag -> SwapFlag +flipSwap IsSwapped = NotSwapped +flipSwap NotSwapped = IsSwapped + +unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b +unSwap NotSwapped f a b = f a b +unSwap IsSwapped f a b = f b a +\end{code} + + +%************************************************************************ +%* * \subsection[FunctionOrData]{FunctionOrData} %* * %************************************************************************ diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index d46759c7fd..a504c5bbe7 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -37,7 +37,7 @@ module DataCon ( dataConRepStrictness, -- ** Predicates on DataCons - isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon, + isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, isVanillaDataCon, classDataCon, dataConCannotMatch, -- * Splitting product types @@ -838,8 +838,8 @@ dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++ \end{code} \begin{code} -isTupleCon :: DataCon -> Bool -isTupleCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc +isTupleDataCon :: DataCon -> Bool +isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc isUnboxedTupleCon :: DataCon -> Bool isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc diff --git a/compiler/basicTypes/DataCon.lhs-boot b/compiler/basicTypes/DataCon.lhs-boot index 3477a4b2e4..94bf889325 100644 --- a/compiler/basicTypes/DataCon.lhs-boot +++ b/compiler/basicTypes/DataCon.lhs-boot @@ -1,9 +1,11 @@ \begin{code} module DataCon where import Name( Name ) +import {-# SOURCE #-} TyCon( TyCon ) data DataCon dataConName :: DataCon -> Name +dataConTyCon :: DataCon -> TyCon isVanillaDataCon :: DataCon -> Bool instance Eq DataCon instance Ord DataCon diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 93762abba9..1d777895e4 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -142,7 +142,7 @@ data IdDetails -- instance C a => C [a] -- has is_silent = 1, because the dfun -- has type dfun :: (D a, C a) => C [a] - -- See the DFun Superclass Invariant in TcInstDcls + -- See Note [Silent superclass arguments] in TcInstDcls -- -- Bool = True <=> the class has only one method, so may be -- implemented with a newtype, so it might be bad diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 1805ccd25e..24c40ccdfd 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -751,9 +751,14 @@ mkPrimOpId prim_op id = mkGlobalId (PrimOpId prim_op) name ty info info = noCafIdInfo - `setSpecInfo` mkSpecInfo (maybeToList $ primOpRules name prim_op) - `setArityInfo` arity + `setSpecInfo` mkSpecInfo (maybeToList $ primOpRules name prim_op) + `setArityInfo` arity `setStrictnessInfo` Just strict_sig + `setInlinePragInfo` neverInlinePragma + -- We give PrimOps a NOINLINE pragma so that we don't + -- get silly warnings from Desugar.dsRule (the inline_shadows_rule + -- test) about a RULE conflicting with a possible inlining + -- cf Trac #7287 -- For each ccall we manufacture a separate CCallOpId, giving it -- a fresh unique, a type that is correct for this particular ccall, diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 3d89f59f04..de8bd7dae7 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -45,7 +45,7 @@ module Name ( -- ** Creating 'Name's mkSystemName, mkSystemNameAt, - mkInternalName, mkDerivedInternalName, + mkInternalName, mkClonedInternalName, mkDerivedInternalName, mkSystemVarName, mkSysTvName, mkFCallName, mkExternalName, mkWiredInName, @@ -266,6 +266,11 @@ mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq -- * for interface files we tidyCore first, which makes -- the OccNames distinct when they need to be +mkClonedInternalName :: Unique -> Name -> Name +mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal + , n_occ = occ, n_loc = loc } + mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index cdd79f5db2..bd829550c8 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -27,7 +27,8 @@ module VarEnv ( modifyVarEnv, modifyVarEnv_Directly, isEmptyVarEnv, foldVarEnv, elemVarEnvByKey, lookupVarEnv_Directly, - filterVarEnv_Directly, restrictVarEnv, + filterVarEnv_Directly, restrictVarEnv, + partitionVarEnv, -- * The InScopeSet type InScopeSet, @@ -384,6 +385,7 @@ extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a +partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a delVarEnvList :: VarEnv a -> [Var] -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a @@ -430,6 +432,7 @@ isEmptyVarEnv = isNullUFM foldVarEnv = foldUFM lookupVarEnv_Directly = lookupUFM_Directly filterVarEnv_Directly = filterUFM_Directly +partitionVarEnv = partitionUFM restrictVarEnv env vs = filterVarEnv_Directly keep env where diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index dcd366f381..250efdd85d 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -838,6 +838,19 @@ lintCoercion the_co@(NthCo n co) _ -> failWithL (hang (ptext (sLit "Bad getNth:")) 2 (ppr the_co $$ ppr s $$ ppr t)) } +lintCoercion the_co@(LRCo lr co) + = do { (_,s,t) <- lintCoercion co + ; case (splitAppTy_maybe s, splitAppTy_maybe t) of + (Just s_pr, Just t_pr) + -> return (k, s_pick, t_pick) + where + s_pick = pickLR lr s_pr + t_pick = pickLR lr t_pr + k = typeKind s_pick + + _ -> failWithL (hang (ptext (sLit "Bad LRCo:")) + 2 (ppr the_co $$ ppr s $$ ppr t)) } + lintCoercion (InstCo co arg_ty) = do { (k,s,t) <- lintCoercion co ; arg_kind <- lintType arg_ty diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs index d2f6691a7c..287f08049e 100644 --- a/compiler/coreSyn/ExternalCore.lhs +++ b/compiler/coreSyn/ExternalCore.lhs @@ -74,6 +74,9 @@ data Ty | UnsafeCoercion Ty Ty | InstCoercion Ty Ty | NthCoercion Int Ty + | LRCoercion LeftOrRight Ty + +data LeftOrRight = CLeft | CRight data Kind = Klifted diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 21037088e1..8844818bdc 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -326,8 +326,13 @@ make_co dflags (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty dflags t1) (mak make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co) make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2) make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co) +make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co) make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty) +make_lr :: LeftOrRight -> C.LeftOrRight +make_lr CLeft = C.CLeft +make_lr CRight = C.CRight + -- Used for both tycon app coercions and axiom instantiations. make_conAppCo :: DynFlags -> C.Qual C.Tcon -> [Coercion] -> C.Ty make_conAppCo dflags con cos = diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs index 26e64ee641..2290810fe1 100644 --- a/compiler/coreSyn/PprExternalCore.lhs +++ b/compiler/coreSyn/PprExternalCore.lhs @@ -114,6 +114,10 @@ pty (UnsafeCoercion t1 t2) = sep [text "%unsafe", paty t1, paty t2] pty (NthCoercion n t) = sep [text "%nth", int n, paty t] +pty (LRCoercion CLeft t) = + sep [text "%left", paty t] +pty (LRCoercion CRight t) = + sep [text "%right", paty t] pty (InstCoercion t1 t2) = sep [text "%inst", paty t1, paty t2] pty t = pbty t diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index 7170f1cede..6bc78a8272 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -470,6 +470,8 @@ data CoercionMap a , km_sym :: CoercionMap a , km_trans :: CoercionMap (CoercionMap a) , km_nth :: IntMap.IntMap (CoercionMap a) + , km_left :: CoercionMap a + , km_right :: CoercionMap a , km_inst :: CoercionMap (TypeMap a) } wrapEmptyKM :: CoercionMap a @@ -477,7 +479,8 @@ wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyNameEnv , km_app = emptyTM, km_forall = emptyTM , km_var = emptyTM, km_axiom = emptyNameEnv , km_unsafe = emptyTM, km_sym = emptyTM, km_trans = emptyTM - , km_nth = emptyTM, km_inst = emptyTM } + , km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM + , km_inst = emptyTM } instance TrieMap CoercionMap where type Key CoercionMap = Coercion @@ -493,7 +496,8 @@ mapC f (KM { km_refl = krefl, km_tc_app = ktc , km_app = kapp, km_forall = kforall , km_var = kvar, km_axiom = kax , km_unsafe = kunsafe, km_sym = ksym, km_trans = ktrans - , km_nth = knth, km_inst = kinst }) + , km_nth = knth, km_left = kml, km_right = kmr + , km_inst = kinst }) = KM { km_refl = mapTM f krefl , km_tc_app = mapNameEnv (mapTM f) ktc , km_app = mapTM (mapTM f) kapp @@ -504,6 +508,8 @@ mapC f (KM { km_refl = krefl, km_tc_app = ktc , km_sym = mapTM f ksym , km_trans = mapTM (mapTM f) ktrans , km_nth = IntMap.map (mapTM f) knth + , km_left = mapTM f kml + , km_right = mapTM f kmr , km_inst = mapTM (mapTM f) kinst } lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a @@ -522,6 +528,8 @@ lkC env co m go (CoVarCo v) = km_var >.> lkVar env v go (SymCo c) = km_sym >.> lkC env c go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c + go (LRCo CLeft c) = km_left >.> lkC env c + go (LRCo CRight c) = km_right >.> lkC env c xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a xtC env co f EmptyKM = xtC env co f wrapEmptyKM @@ -534,9 +542,11 @@ xtC env (UnsafeCo t1 t2) f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>> xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f } xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c |>> xtBndr env v f } -xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f } -xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f } -xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f } +xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f } +xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f } +xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f } +xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f } +xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f } fdC :: (a -> b -> b) -> CoercionMap a -> b -> b fdC _ EmptyKM = \z -> z @@ -550,6 +560,8 @@ fdC k m = foldTM k (km_refl m) . foldTM k (km_sym m) . foldTM (foldTM k) (km_trans m) . foldTM (foldTM k) (km_nth m) + . foldTM k (km_left m) + . foldTM k (km_right m) . foldTM (foldTM k) (km_inst m) \end{code} diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 75c3d11b91..ad590ae8d8 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -529,7 +529,7 @@ similar) at the same time that we create the constructors. You can tell tuple constructors using \begin{verbatim} - Id.isTupleCon + Id.isTupleDataCon \end{verbatim} You can see if one constructor is infix with this clearer code :-)))))))))) \begin{verbatim} diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 493ff0c13e..551355cb62 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -576,6 +576,7 @@ addTickHsExpr (HsWrap w e) = (addTickHsExpr e) -- explicitly no tick on inside addTickHsExpr e@(HsType _) = return e +addTickHsExpr HsHole = panic "addTickHsExpr.HsHole" -- Others dhould never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) @@ -584,19 +585,19 @@ addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id) addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') } addTickTupArg (Missing ty) = return (Missing ty) -addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id -> TM (MatchGroup Id) +addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id)) addTickMatchGroup is_lam (MatchGroup matches ty) = do let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches return $ MatchGroup matches' ty -addTickMatch :: Bool -> Bool -> Match Id -> TM (Match Id) +addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id)) addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs return $ Match pats opSig gRHSs' -addTickGRHSs :: Bool -> Bool -> GRHSs Id -> TM (GRHSs Id) +addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id)) addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds @@ -605,7 +606,7 @@ addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do where binders = collectLocalBinders local_binds -addTickGRHS :: Bool -> Bool -> GRHS Id -> TM (GRHS Id) +addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id)) addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickGRHSBody isOneOfMany isLambda expr) @@ -623,20 +624,20 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do _otherwise -> addTickLHsExprRHS expr -addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id] +addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id] addTickLStmts isGuard stmts = do (stmts, _) <- addTickLStmts' isGuard stmts (return ()) return stmts -addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a - -> TM ([LStmt Id], a) +addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a + -> TM ([ExprLStmt Id], a) addTickLStmts' isGuard lstmts res = bindLocals (collectLStmtsBinders lstmts) $ do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts ; a <- res ; return (lstmts', a) } -addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id) +addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id)) addTickStmt _isGuard (LastStmt e ret) = do liftM2 LastStmt (addTickLHsExpr e) @@ -647,8 +648,8 @@ addTickStmt _isGuard (BindStmt pat e bind fail) = do (addTickLHsExprRHS e) (addTickSyntaxExpr hpcSrcSpan bind) (addTickSyntaxExpr hpcSrcSpan fail) -addTickStmt isGuard (ExprStmt e bind' guard' ty) = do - liftM4 ExprStmt +addTickStmt isGuard (BodyStmt e bind' guard' ty) = do + liftM4 BodyStmt (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') @@ -750,63 +751,65 @@ addTickLHsCmd (L pos c0) = do return $ L pos c1 addTickHsCmd :: HsCmd Id -> TM (HsCmd Id) -addTickHsCmd (HsLam matchgroup) = - liftM HsLam (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsApp c e) = - liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e) +addTickHsCmd (HsCmdLam matchgroup) = + liftM HsCmdLam (addTickCmdMatchGroup matchgroup) +addTickHsCmd (HsCmdApp c e) = + liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e) +{- addTickHsCmd (OpApp e1 c2 fix c3) = liftM4 OpApp (addTickLHsExpr e1) (addTickLHsCmd c2) (return fix) (addTickLHsCmd c3) -addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e) -addTickHsCmd (HsCase e mgs) = - liftM2 HsCase +-} +addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e) +addTickHsCmd (HsCmdCase e mgs) = + liftM2 HsCmdCase (addTickLHsExpr e) (addTickCmdMatchGroup mgs) -addTickHsCmd (HsIf cnd e1 c2 c3) = - liftM3 (HsIf cnd) +addTickHsCmd (HsCmdIf cnd e1 c2 c3) = + liftM3 (HsCmdIf cnd) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsLet binds c) = +addTickHsCmd (HsCmdLet binds c) = bindLocals (collectLocalBinders binds) $ - liftM2 HsLet + liftM2 HsCmdLet (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) -addTickHsCmd (HsDo cxt stmts srcloc) +addTickHsCmd (HsCmdDo stmts srcloc) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsDo cxt stmts' srcloc) } + ; return (HsCmdDo stmts' srcloc) } -addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) = - liftM5 HsArrApp +addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) = + liftM5 HsCmdArrApp (addTickLHsExpr e1) (addTickLHsExpr e2) (return ty1) (return arr_ty) (return lr) -addTickHsCmd (HsArrForm e fix cmdtop) = - liftM3 HsArrForm +addTickHsCmd (HsCmdArrForm e fix cmdtop) = + liftM3 HsCmdArrForm (addTickLHsExpr e) (return fix) (mapM (liftL (addTickHsCmdTop)) cmdtop) -- Others should never happen in a command context. -addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) +--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) -addTickCmdMatchGroup :: MatchGroup Id -> TM (MatchGroup Id) +addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id)) addTickCmdMatchGroup (MatchGroup matches ty) = do matches' <- mapM (liftL addTickCmdMatch) matches return $ MatchGroup matches' ty -addTickCmdMatch :: Match Id -> TM (Match Id) +addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id)) addTickCmdMatch (Match pats opSig gRHSs) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickCmdGRHSs gRHSs return $ Match pats opSig gRHSs' -addTickCmdGRHSs :: GRHSs Id -> TM (GRHSs Id) +addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id)) addTickCmdGRHSs (GRHSs guarded local_binds) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds @@ -815,7 +818,7 @@ addTickCmdGRHSs (GRHSs guarded local_binds) = do where binders = collectLocalBinders local_binds -addTickCmdGRHS :: GRHS Id -> TM (GRHS Id) +addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id)) -- The *guards* are *not* Cmds, although the body is -- C.f. addTickGRHS for the BinBox stuff addTickCmdGRHS (GRHS stmts cmd) @@ -823,12 +826,12 @@ addTickCmdGRHS (GRHS stmts cmd) stmts (addTickLHsCmd cmd) ; return $ GRHS stmts' expr' } -addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id] +addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)] addTickLCmdStmts stmts = do (stmts, _) <- addTickLCmdStmts' stmts (return ()) return stmts -addTickLCmdStmts' :: [LStmt Id] -> TM a -> TM ([LStmt Id], a) +addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a) addTickLCmdStmts' lstmts res = bindLocals binders $ do lstmts' <- mapM (liftL addTickCmdStmt) lstmts @@ -837,7 +840,7 @@ addTickLCmdStmts' lstmts res where binders = collectLStmtsBinders lstmts -addTickCmdStmt :: Stmt Id -> TM (Stmt Id) +addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id)) addTickCmdStmt (BindStmt pat c bind fail) = do liftM4 BindStmt (addTickLPat pat) @@ -848,8 +851,8 @@ addTickCmdStmt (LastStmt c ret) = do liftM2 LastStmt (addTickLHsCmd c) (addTickSyntaxExpr hpcSrcSpan ret) -addTickCmdStmt (ExprStmt c bind' guard' ty) = do - liftM4 ExprStmt +addTickCmdStmt (BodyStmt c bind' guard' ty) = do + liftM4 BodyStmt (addTickLHsCmd c) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') @@ -1142,7 +1145,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") \begin{code} -matchesOneOfMany :: [LMatch Id] -> Bool +matchesOneOfMany :: [LMatch Id body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 1da6a77976..66e29f8348 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -50,31 +50,37 @@ import Outputable import Bag import VarSet import SrcLoc - +import ListSetOps( assocDefault ) +import FastString import Data.List \end{code} \begin{code} data DsCmdEnv = DsCmdEnv { - meth_binds :: [CoreBind], arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr } -mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv -mkCmdEnv ids = do - (meth_binds, ds_meths) <- dsSyntaxTable ids - return $ DsCmdEnv { - meth_binds = meth_binds, - arr_id = Var (lookupEvidence ds_meths arrAName), - compose_id = Var (lookupEvidence ds_meths composeAName), - first_id = Var (lookupEvidence ds_meths firstAName), - app_id = Var (lookupEvidence ds_meths appAName), - choice_id = Var (lookupEvidence ds_meths choiceAName), - loop_id = Var (lookupEvidence ds_meths loopAName) - } - -bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr -bindCmdEnv ids body = foldr Let body (meth_binds ids) +mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv) +-- See Note [CmdSyntaxTable] in HsExpr +mkCmdEnv tc_meths + = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths + ; return (meth_binds, DsCmdEnv { + arr_id = Var (find_meth prs arrAName), + compose_id = Var (find_meth prs composeAName), + first_id = Var (find_meth prs firstAName), + app_id = Var (find_meth prs appAName), + choice_id = Var (find_meth prs choiceAName), + loop_id = Var (find_meth prs loopAName) + }) } + where + mk_bind (std_name, expr) + = do { rhs <- dsExpr expr + ; id <- newSysLocalDs (exprType rhs) + ; return (NonRec id rhs, (std_name, id)) } + + find_meth prs std_name + = assocDefault (mk_panic std_name) prs std_name + mk_panic std_name = pprPanic "mkCmdEnv" (ptext (sLit "Not found:") <+> ppr std_name) -- arr :: forall b c. (b -> c) -> a b c do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr @@ -245,7 +251,7 @@ dsProcExpr -> LHsCmdTop Id -> DsM CoreExpr dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do - meth_ids <- mkCmdEnv ids + (meth_binds, meth_ids) <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders pat) (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd let env_ty = mkBigCoreVarTupTy env_ids @@ -256,7 +262,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty (Lam var match_code) core_cmd - return (bindCmdEnv meth_ids proc_code) + return (mkLets meth_binds proc_code) dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c) \end{code} @@ -289,7 +295,7 @@ dsCmd :: DsCmdEnv -- arrow combinators -- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f dsCmd ids local_vars stack res_ty - (HsArrApp arrow arg arrow_ty HsFirstOrderApp _) + (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -315,7 +321,7 @@ dsCmd ids local_vars stack res_ty -- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app dsCmd ids local_vars stack res_ty - (HsArrApp arrow arg arrow_ty HsHigherOrderApp _) + (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -344,7 +350,7 @@ dsCmd ids local_vars stack res_ty -- -- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c -dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do +dsCmd ids local_vars stack res_ty (HsCmdApp cmd arg) env_ids = do core_arg <- dsLExpr arg let arg_ty = exprType core_arg @@ -375,7 +381,7 @@ dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do -- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c dsCmd ids local_vars stack res_ty - (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) + (HsCmdLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) @@ -402,7 +408,7 @@ dsCmd ids local_vars stack res_ty return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body, free_vars `minusVarSet` pat_vars) -dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids +dsCmd ids local_vars stack res_ty (HsCmdPar cmd) env_ids = dsLCmd ids local_vars stack res_ty cmd env_ids -- A, xs |- e :: Bool @@ -415,7 +421,7 @@ dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids -- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>> -- c1 ||| c2 -dsCmd ids local_vars stack res_ty (HsIf mb_fun cond then_cmd else_cmd) +dsCmd ids local_vars stack res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) env_ids = do core_cond <- dsLExpr cond (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd @@ -476,7 +482,7 @@ case bodies, containing the following fields: bodies with |||. \begin{code} -dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty)) +dsCmd ids local_vars stack res_ty (HsCmdCase exp (MatchGroup matches match_ty)) env_ids = do stack_ids <- mapM newSysLocalDs stack @@ -535,7 +541,7 @@ dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty)) -- -- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c -dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do +dsCmd ids local_vars stack res_ty (HsCmdLet binds body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = defined_vars `unionVarSet` local_vars @@ -554,7 +560,7 @@ dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do core_body, exprFreeIds core_binds `intersectVarSet` local_vars) -dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids +dsCmd ids local_vars [] res_ty (HsCmdDo stmts _) env_ids = dsCmdDo ids local_vars res_ty stmts env_ids -- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t @@ -562,16 +568,16 @@ dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids -- ----------------------------------- -- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn -dsCmd _ids local_vars _stack _res_ty (HsArrForm op _ args) env_ids = do +dsCmd _ids local_vars _stack _res_ty (HsCmdArrForm op _ args) env_ids = do let env_ty = mkBigCoreVarTupTy env_ids core_op <- dsLExpr op (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args return (mkApps (App core_op (Type env_ty)) core_args, unionVarSets fv_sets) -dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do - (expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids - return (Tick tickish expr1, id_set) +--dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do +-- (expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids +-- return (Tick tickish expr1, id_set) dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) @@ -586,7 +592,7 @@ dsTrimCmdArg -> DsM (CoreExpr, -- desugared expression IdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do - meth_ids <- mkCmdEnv ids + (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd stack_ids <- mapM newSysLocalDs stack trim_code <- matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids) @@ -595,7 +601,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do in_ty' = envStackType env_ids' stack arg_code = if env_ids' == env_ids then core_cmd else do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd - return (bindCmdEnv meth_ids arg_code, free_vars) + return (mkLets meth_binds arg_code, free_vars) -- Given A | xs |- c :: [ts] t, builds c with xs fed back. -- Typically needs to be prefixed with arr (\p -> ((xs)*ts)) @@ -638,7 +644,7 @@ Translation of command judgements of the form dsCmdDo :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> Type -- return type of the statement - -> [LStmt Id] -- statements to desugar + -> [CmdLStmt Id] -- statements to desugar -> [Id] -- list of vars in the input to this statement -- This is typically fed back, -- so don't pull on it too early @@ -673,7 +679,7 @@ A statement maps one local environment to another, and is represented as an arrow from one tuple type to another. A statement sequence is translated to a composition of such arrows. \begin{code} -dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> LStmt Id -> [Id] +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id] -> DsM (CoreExpr, IdSet) dsCmdLStmt ids local_vars out_ids cmd env_ids = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids @@ -682,7 +688,7 @@ dsCmdStmt :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- list of vars in the output of this statement - -> Stmt Id -- statement to desugar + -> CmdStmt Id -- statement to desugar -> [Id] -- list of vars in the input to this statement -- This is typically fed back, -- so don't pull on it too early @@ -697,7 +703,7 @@ dsCmdStmt -- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> -- arr snd >>> ss -dsCmdStmt ids local_vars out_ids (ExprStmt cmd _ _ c_ty) env_ids = do +dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd core_mux <- matchEnvStack env_ids [] (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids)) @@ -860,7 +866,7 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) dsRecCmd :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement - -> [LStmt Id] -- list of statements inside the RecCmd + -> [CmdLStmt Id] -- list of statements inside the RecCmd -> [Id] -- list of vars defined here and used later -> [HsExpr Id] -- expressions corresponding to later_ids -> [Id] -- list of vars fed back through the loop @@ -938,7 +944,7 @@ dsfixCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- output vars of these statements - -> [LStmt Id] -- statements to desugar + -> [CmdLStmt Id] -- statements to desugar -> DsM (CoreExpr, -- desugared expression IdSet, -- subset of local vars that occur free [Id]) -- same local vars as a list @@ -950,7 +956,7 @@ dsCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- output vars of these statements - -> [LStmt Id] -- statements to desugar + -> [CmdLStmt Id] -- statements to desugar -> [Id] -- list of vars in the input to these statements -> DsM (CoreExpr, -- desugared expression IdSet) -- subset of local vars that occur free @@ -995,28 +1001,28 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" List of leaf expressions, with set of variables bound in each \begin{code} -leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)] +leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)] leavesMatch (L _ (Match pats _ (GRHSs grhss binds))) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` mkVarSet (collectLocalBinders binds) in - [(expr, + [(body, mkVarSet (collectLStmtsBinders stmts) `unionVarSet` defined_vars) - | L _ (GRHS stmts expr) <- grhss] + | L _ (GRHS stmts body) <- grhss] \end{code} Replace the leaf commands in a match \begin{code} replaceLeavesMatch - :: Type -- new result type - -> [LHsExpr Id] -- replacement leaf expressions of that type - -> LMatch Id -- the matches of a case command - -> ([LHsExpr Id],-- remaining leaf expressions - LMatch Id) -- updated match + :: Type -- new result type + -> [Located (body' Id)] -- replacement leaf expressions of that type + -> LMatch Id (Located (body Id)) -- the matches of a case command + -> ([Located (body' Id)], -- remaining leaf expressions + LMatch Id (Located (body' Id))) -- updated match replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss @@ -1024,10 +1030,10 @@ replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) (leaves', L loc (Match pat mt (GRHSs grhss' binds))) replaceLeavesGRHS - :: [LHsExpr Id] -- replacement leaf expressions of that type - -> LGRHS Id -- rhss of a case command - -> ([LHsExpr Id],-- remaining leaf expressions - LGRHS Id) -- updated GRHS + :: [Located (body' Id)] -- replacement leaf expressions of that type + -> LGRHS Id (Located (body Id)) -- rhss of a case command + -> ([Located (body' Id)], -- remaining leaf expressions + LGRHS Id (Located (body' Id))) -- updated GRHS replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _)) = (leaves, L loc (GRHS stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" @@ -1113,16 +1119,16 @@ add_ev_bndr (EvBind b _) bs | isId b = b:bs | otherwise = bs -- A worry: what about coercion variable binders?? -collectLStmtsBinders :: [LStmt Id] -> [Id] +collectLStmtsBinders :: [LStmt Id body] -> [Id] collectLStmtsBinders = concatMap collectLStmtBinders -collectLStmtBinders :: LStmt Id -> [Id] +collectLStmtBinders :: LStmt Id body -> [Id] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: Stmt Id -> [Id] +collectStmtBinders :: Stmt Id body -> [Id] collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (LetStmt binds) = collectLocalBinders binds -collectStmtBinders (ExprStmt {}) = [] +collectStmtBinders (BodyStmt {}) = [] collectStmtBinders (LastStmt {}) = [] collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders $ [ s | ParStmtBlock ss _ _ <- xs, s <- ss] diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 4fa1ec00c9..95d36f3879 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -440,8 +440,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | otherwise = putSrcSpanDs loc $ - do { let poly_name = idName poly_id - ; spec_name <- newLocalName poly_name + do { uniq <- newUnique + ; let poly_name = idName poly_id + spec_name = mkClonedInternalName uniq poly_name ; (bndrs, ds_lhs) <- liftM collectBinders (dsHsWrapper spec_co (Var poly_id)) ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs) @@ -740,10 +741,6 @@ dsEvTerm (EvCast tm co) -- 'v' is always a lifted evidence variable so it is -- unnecessary to call varToCoreExpr v here. -dsEvTerm (EvKindCast v co) - = do { v' <- dsEvTerm v - ; dsTcCoercion co $ (\_ -> v') } - dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms ; return (Var df `mkTyApps` tys `mkApps` tms') } dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox @@ -833,6 +830,7 @@ ds_tc_coercion subst tc_co go (TcSymCo co) = mkSymCo (go co) go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2) go (TcNthCo n co) = mkNthCo n (go co) + go (TcLRCo lr co) = mkLRCo lr (go co) go (TcInstCo co ty) = mkInstCo (go co) ty go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 8c53c1aea1..88df581844 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -216,6 +216,8 @@ dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty)) dsExpr (HsApp fun arg) = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg + +dsExpr HsHole = panic "dsExpr: HsHole" \end{code} Note [Desugaring vars] @@ -322,12 +324,12 @@ dsExpr (HsLet binds body) = do -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty -dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts) -dsExpr (HsDo DoExpr stmts _) = dsDo stmts -dsExpr (HsDo GhciStmt stmts _) = dsDo stmts -dsExpr (HsDo MDoExpr stmts _) = dsDo stmts -dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts +dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty +dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts) +dsExpr (HsDo DoExpr stmts _) = dsDo stmts +dsExpr (HsDo GhciStmtCtxt stmts _) = dsDo stmts +dsExpr (HsDo MDoExpr stmts _) = dsDo stmts +dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts dsExpr (HsIf mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr @@ -717,7 +719,7 @@ handled in DsListComp). Basically does the translation given in the Haskell 98 report: \begin{code} -dsDo :: [LStmt Id] -> DsM CoreExpr +dsDo :: [ExprLStmt Id] -> DsM CoreExpr dsDo stmts = goL stmts where @@ -728,7 +730,7 @@ dsDo stmts = ASSERT( null stmts ) dsLExpr body -- The 'return' op isn't used for 'do' expressions - go _ (ExprStmt rhs then_expr _ _) stmts + go _ (BodyStmt rhs then_expr _ _) stmts = do { rhs2 <- dsLExpr rhs ; warnDiscardedDoBindings rhs (exprType rhs2) ; then_expr2 <- dsExpr then_expr diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index 9e84e46e9f..1af39d1a0f 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -40,7 +40,7 @@ producing an expression with a runtime error in the corner if necessary. The type argument gives the type of the @ei@. \begin{code} -dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr +dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr dsGuarded grhss rhs_ty = do match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty @@ -52,7 +52,7 @@ In contrast, @dsGRHSs@ produces a @MatchResult@. \begin{code} dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from - -> GRHSs Id -- Guarded RHSs + -> GRHSs Id (LHsExpr Id) -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do @@ -66,7 +66,7 @@ dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do -- return match_result2 -dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id -> DsM MatchResult +dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty \end{code} @@ -79,31 +79,31 @@ dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) %************************************************************************ \begin{code} -matchGuards :: [Stmt Id] -- Guard - -> HsStmtContext Name -- Context - -> LHsExpr Id -- RHS - -> Type -- Type of RHS of guard +matchGuards :: [GuardStmt Id] -- Guard + -> HsStmtContext Name -- Context + -> LHsExpr Id -- RHS + -> Type -- Type of RHS of guard -> DsM MatchResult --- See comments with HsExpr.Stmt re what an ExprStmt means +-- See comments with HsExpr.Stmt re what a BodyStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) matchGuards [] _ rhs _ = do { core_rhs <- dsLExpr rhs ; return (cantFailMatchResult core_rhs) } - -- ExprStmts must be guards + -- BodyStmts must be guards -- Turn an "otherwise" guard is a no-op. This ensures that -- you don't get a "non-exhaustive eqns" message when the guards -- finish in "otherwise". -- NB: The success of this clause depends on the typechecker not -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors -- If it does, you'll get bogus overlap warnings -matchGuards (ExprStmt e _ _ _ : stmts) ctx rhs rhs_ty +matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty | Just addTicks <- isTrueLHsExpr e = do match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs addTicks match_result) -matchGuards (ExprStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do +matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index efe14f2678..b590a92057 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -43,7 +43,7 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject). There will be at least one ``qualifier'' in the input. \begin{code} -dsListComp :: [LStmt Id] +dsListComp :: [ExprLStmt Id] -> Type -- Type of entire list -> DsM CoreExpr dsListComp lquals res_ty = do @@ -89,7 +89,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _) -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed -- list and the tuple that you need to bind from that list in order to proceed with your desugaring -dsTransStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) +dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id) dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap , trS_by = by, trS_using = using }) = do let (from_bndrs, to_bndrs) = unzip binderMap @@ -204,7 +204,7 @@ with the Unboxed variety. \begin{code} -deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr +deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr deListComp [] _ = panic "deListComp" @@ -215,7 +215,7 @@ deListComp (LastStmt body _ : quals) list ; return (mkConsExpr (exprType core_body) core_body list) } -- Non-last: must be a guard -deListComp (ExprStmt guard _ _ _ : quals) list = do -- rule B above +deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above core_guard <- dsLExpr guard core_rest <- deListComp quals list return (mkIfThenElse core_guard core_rest list) @@ -256,7 +256,7 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" \begin{code} deBindComp :: OutPat Id -> CoreExpr - -> [Stmt Id] + -> [ExprStmt Id] -> CoreExpr -> DsM (Expr Id) deBindComp pat core_list1 quals core_list2 = do @@ -309,8 +309,8 @@ TE[ e | p <- l , q ] c n = let \end{verbatim} \begin{code} -dfListComp :: Id -> Id -- 'c' and 'n' - -> [Stmt Id] -- the rest of the qual's +dfListComp :: Id -> Id -- 'c' and 'n' + -> [ExprStmt Id] -- the rest of the qual's -> DsM CoreExpr dfListComp _ _ [] = panic "dfListComp" @@ -321,7 +321,7 @@ dfListComp c_id n_id (LastStmt body _ : quals) ; return (mkApps (Var c_id) [core_body, Var n_id]) } -- Non-last: must be a guard -dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) = do +dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do core_guard <- dsLExpr guard core_rest <- dfListComp c_id n_id quals return (mkIfThenElse core_guard core_rest (Var n_id)) @@ -347,8 +347,8 @@ dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" dfBindComp :: Id -> Id -- 'c' and 'n' - -> (LPat Id, CoreExpr) - -> [Stmt Id] -- the rest of the qual's + -> (LPat Id, CoreExpr) + -> [ExprStmt Id] -- the rest of the qual's -> DsM CoreExpr dfBindComp c_id n_id (pat, core_list1) quals = do -- find the required type @@ -469,7 +469,7 @@ mkUnzipBind _ elt_tys -- -- [:e | qss:] = <<[:e | qss:]>> () [:():] -- -dsPArrComp :: [Stmt Id] +dsPArrComp :: [ExprStmt Id] -> DsM CoreExpr -- Special case for parallel comprehension @@ -505,7 +505,7 @@ dsPArrComp qs = do -- no ParStmt in `qs' -- the work horse -- -dePArrComp :: [Stmt Id] +dePArrComp :: [ExprStmt Id] -> LPat Id -- the current generator pattern -> CoreExpr -- the current generator expression -> DsM CoreExpr @@ -524,7 +524,7 @@ dePArrComp (LastStmt e' _ : quals) pa cea -- -- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) -- -dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do +dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do filterP <- dsDPHBuiltin filterPVar let ty = parrElemType cea (clam,_) <- deLambda ty pa b @@ -601,7 +601,7 @@ dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt" -- where -- {x_1, ..., x_n} = DV (qs) -- -dePArrParComp :: [ParStmtBlock Id Id] -> [Stmt Id] -> DsM CoreExpr +dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr dePArrParComp qss quals = do (pQss, ceQss) <- deParStmt qss dePArrComp quals pQss ceQss @@ -663,15 +663,15 @@ Translation for monad comprehensions \begin{code} -- Entry point for monad comprehension desugaring -dsMonadComp :: [LStmt Id] -> DsM CoreExpr +dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr dsMonadComp stmts = dsMcStmts stmts -dsMcStmts :: [LStmt Id] -> DsM CoreExpr +dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr dsMcStmts [] = panic "dsMcStmts" dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) --------------- -dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr +dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr dsMcStmt (LastStmt body ret_op) stmts = ASSERT( null stmts ) @@ -693,7 +693,7 @@ dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts -- -- [ .. | exp, stmts ] -- -dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts +dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts = do { exp' <- dsLExpr exp ; guard_exp' <- dsExpr guard_exp ; then_exp' <- dsExpr then_exp @@ -801,7 +801,7 @@ dsMcBindStmt :: LPat Id -> CoreExpr -- ^ the desugared rhs of the bind statement -> SyntaxExpr Id -> SyntaxExpr Id - -> [LStmt Id] + -> [ExprLStmt Id] -> DsM CoreExpr dsMcBindStmt pat rhs' bind_op fail_op stmts = do { body <- dsMcStmts stmts @@ -836,7 +836,7 @@ dsMcBindStmt pat rhs' bind_op fail_op stmts -- returns the desugaring of -- [ (a,b,c) | quals ] -dsInnerMonadComp :: [LStmt Id] +dsInnerMonadComp :: [ExprLStmt Id] -> [Id] -- Return a tuple of these variables -> HsExpr Id -- The monomorphic "return" operator -> DsM CoreExpr diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 15dab47ca1..d9e851ae62 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -922,7 +922,7 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs -- FIXME: I haven't got the types here right yet repE e@(HsDo ctxt sts _) - | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False } + | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; e' <- repDoE (nonEmptyCoreList zs); wrapGenSyms ss e' } @@ -980,7 +980,7 @@ repE e = notHandled "Expression form" (ppr e) ----------------------------------------------------------------------------- -- Building representations of auxillary structures like Match, Clause, Stmt, -repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ) +repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ) repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { @@ -992,7 +992,7 @@ repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) = ; wrapGenSyms (ss1++ss2) match }}} repMatchTup _ = panic "repMatchTup: case alt with more than one arg" -repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ) +repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ) repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { @@ -1003,23 +1003,23 @@ repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) = ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} -repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ) +repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ) repGuards [L _ (GRHS [] e)] - = do { a <- repLE e - ; repNormal a } -repGuards alts - = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts - ; body <- repGuarded (nonEmptyCoreList alts') - ; wrapGenSyms (concat binds) body } - -repLGRHS :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) -repLGRHS (L _ (GRHS [L _ (ExprStmt guard _ _ _)] rhs)) - = do { guarded <- repLNormalGE guard rhs + = do {a <- repLE e; repNormal a } +repGuards other + = do { zs <- mapM repLGRHS other + ; let (xs, ys) = unzip zs + ; gd <- repGuarded (nonEmptyCoreList ys) + ; wrapGenSyms (concat xs) gd } + +repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) +repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2)) + = do { guarded <- repLNormalGE e1 e2 ; return ([], guarded) } -repLGRHS (L _ (GRHS stmts rhs)) - = do { (gs, stmts') <- repLSts stmts - ; rhs' <- addBinds gs $ repLE rhs - ; guarded <- repPatGE (nonEmptyCoreList stmts') rhs' +repLGRHS (L _ (GRHS ss rhs)) + = do { (gs, ss') <- repLSts ss + ; rhs' <- addBinds gs $ repLE rhs + ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' ; return (gs, guarded) } repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) @@ -1055,10 +1055,10 @@ repFields (HsRecFields { rec_flds = flds }) -- The helper function repSts computes the translation of each sub expression -- and a bunch of prefix bindings denoting the dynamic renaming. -repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) repLSts stmts = repSts (map unLoc stmts) -repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) repSts (BindStmt p e _ _ : ss) = do { e2 <- repLE e ; ss1 <- mkGenSyms (collectPatBinders p) @@ -1072,7 +1072,7 @@ repSts (LetStmt bs : ss) = ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } -repSts (ExprStmt e _ _ _ : ss) = +repSts (BodyStmt e _ _ _ : ss) = do { e2 <- repLE e ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss @@ -1190,7 +1190,7 @@ rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like -- (\ p1 .. pn -> exp) by causing an error. -repLambda :: LMatch Name -> DsM (Core TH.ExpQ) +repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ) repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 0053484b13..0b14946793 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -39,8 +39,6 @@ module DsUtils ( mkSelectorBinds, - dsSyntaxTable, lookupEvidence, - selectSimpleMatchVarL, selectMatchVars, selectMatchVar, mkOptTickBox, mkBinaryTickBox ) where @@ -48,7 +46,6 @@ module DsUtils ( #include "HsVersions.h" import {-# SOURCE #-} Match ( matchSimply ) -import {-# SOURCE #-} DsExpr( dsExpr ) import HsSyn import TcHsSyn @@ -60,7 +57,6 @@ import CoreUtils import MkCore import MkId import Id -import Name import Literal import TyCon import DataCon @@ -75,7 +71,6 @@ import PrelNames import Outputable import SrcLoc import Util -import ListSetOps import DynFlags import FastString @@ -85,36 +80,6 @@ import Control.Monad ( zipWithM ) %************************************************************************ %* * - Rebindable syntax -%* * -%************************************************************************ - -\begin{code} -dsSyntaxTable :: SyntaxTable Id - -> DsM ([CoreBind], -- Auxiliary bindings - [(Name,Id)]) -- Maps the standard name to its value - -dsSyntaxTable rebound_ids = do - (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids - return (concat binds_s, prs) - where - -- The cheapo special case can happen when we - -- make an intermediate HsDo when desugaring a RecStmt - mk_bind (std_name, HsVar id) = return ([], (std_name, id)) - mk_bind (std_name, expr) = do - rhs <- dsExpr expr - id <- newSysLocalDs (exprType rhs) - return ([NonRec id rhs], (std_name, id)) - -lookupEvidence :: [(Name, Id)] -> Name -> Id -lookupEvidence prs std_name - = assocDefault (mk_panic std_name) prs std_name - where - mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name) -\end{code} - -%************************************************************************ -%* * \subsection{ Selecting match variables} %* * %************************************************************************ diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index adb9099c14..c650e103a8 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -664,9 +664,9 @@ Call @match@ with all of this information! \end{enumerate} \begin{code} -matchWrapper :: HsMatchContext Name -- For shadowing warning messages - -> MatchGroup Id -- Matches being desugared - -> DsM ([Id], CoreExpr) -- Results +matchWrapper :: HsMatchContext Name -- For shadowing warning messages + -> MatchGroup Id (LHsExpr Id) -- Matches being desugared + -> DsM ([Id], CoreExpr) -- Results \end{code} There is one small problem with the Lambda Patterns, when somebody diff --git a/compiler/deSugar/Match.lhs-boot b/compiler/deSugar/Match.lhs-boot index d10cda961e..66ecc8aba6 100644 --- a/compiler/deSugar/Match.lhs-boot +++ b/compiler/deSugar/Match.lhs-boot @@ -4,7 +4,7 @@ import Var ( Id ) import TcType ( Type ) import DsMonad ( DsM, EquationInfo, MatchResult ) import CoreSyn ( CoreExpr ) -import HsSyn ( LPat, HsMatchContext, MatchGroup ) +import HsSyn ( LPat, HsMatchContext, MatchGroup, LHsExpr ) import Name ( Name ) match :: [Id] @@ -14,7 +14,7 @@ match :: [Id] matchWrapper :: HsMatchContext Name - -> MatchGroup Id + -> MatchGroup Id (LHsExpr Id) -> DsM ([Id], CoreExpr) matchSimply diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 57dadc5475..b19f04f033 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -488,7 +488,7 @@ cvtLocalDecs doc ds ; unless (null bads) (failWith (mkBadDecMsg doc bads)) ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } -cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName) +cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) cvtClause (Clause ps body wheres) = do { ps' <- cvtPats ps ; g' <- cvtGuard body @@ -676,7 +676,7 @@ cvtHsDo do_or_lc stmts ; let Just (stmts'', last') = snocView stmts' ; last'' <- case last' of - L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body)) + L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void } @@ -685,11 +685,11 @@ cvtHsDo do_or_lc stmts , nest 2 $ Outputable.ppr stmt , ptext (sLit "(It should be an expression.)") ] -cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName] +cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)] cvtStmts = mapM cvtStmt -cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName) -cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' } +cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName)) +cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds ; returnL $ LetStmt ds' } @@ -697,20 +697,20 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' n where cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } -cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName) +cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) cvtMatch (TH.Match p body decs) = do { p' <- cvtPat p ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') } -cvtGuard :: TH.Body -> CvtM [LGRHS RdrName] +cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] } -cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName) +cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs - ; g' <- returnL $ mkExprStmt ge' + ; g' <- returnL $ mkBodyStmt ge' ; returnL $ GRHS [g'] rhs' } cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs ; returnL $ GRHS gs' rhs' } diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 26097df6c4..f15ef5d3cc 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -18,7 +18,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. module HsBinds where -import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, +import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, MatchGroup, pprFunBind, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) @@ -106,7 +106,7 @@ data HsBindLR idL idR fun_infix :: Bool, -- ^ True => infix declaration - fun_matches :: MatchGroup idR, -- ^ The payload + fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of -- the Id. Example: @@ -131,7 +131,7 @@ data HsBindLR idL idR | PatBind { -- The pattern is never a simple variable; -- That case is done by FunBind pat_lhs :: LPat idL, - pat_rhs :: GRHSs idR, + pat_rhs :: GRHSs idR (LHsExpr idR), pat_rhs_ty :: PostTcType, -- Type of the GRHSs bind_fvs :: NameSet, -- See Note [Bind free vars] pat_ticks :: (Maybe (Tickish Id), [Maybe (Tickish Id)]) diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 80429d7c9c..ef0263d05d 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -82,27 +82,49 @@ noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after, noSyntaxExpr = HsLit (HsString (fsLit "noSyntaxExpr")) -type SyntaxTable id = [(Name, SyntaxExpr id)] --- ^ Currently used only for 'CmdTop' (sigh) --- --- * Before the renamer, this list is 'noSyntaxTable' --- --- * After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ --- For example, for the 'return' op of a monad --- --- * normal case: @(GHC.Base.return, HsVar GHC.Base.return)@ --- --- * with rebindable syntax: @(GHC.Base.return, return_22)@ --- where @return_22@ is whatever @return@ is in scope --- --- * After the type checker, it takes the form @[(std_name, <expression>)]@ --- where @<expression>@ is the evidence for the method +type CmdSyntaxTable id = [(Name, SyntaxExpr id)] +-- See Note [CmdSyntaxTable] -noSyntaxTable :: SyntaxTable id +noSyntaxTable :: CmdSyntaxTable id noSyntaxTable = [] +\end{code} +Note [CmdSyntaxtable] +~~~~~~~~~~~~~~~~~~~~~ +Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps +track of the methods needed for a Cmd. + +* Before the renamer, this list is 'noSyntaxTable' + +* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ + For example, for the 'arr' method + * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) + * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) + where @arr_22@ is whatever 'arr' is in scope + +* After the type checker, it takes the form [(std_name, <expression>)] + where <expression> is the evidence for the method. This evidence is + instantiated with the class, but is still polymorphic in everything + else. For example, in the case of 'arr', the evidence has type + forall b c. (b->c) -> a b c + where 'a' is the ambient type of the arrow. This polymorphism is + important because the desugarer uses the same evidence at multiple + different types. + +This is Less Cool than what we normally do for rebindable syntax, which is to +make fully-instantiated piece of evidence at every use site. The Cmd way +is Less Cool because + * The renamer has to predict which methods are needed. + See the tedious RnExpr.methodNamesCmd. + + * The desugarer has to know the polymorphic type of the instantiated + method. This is checked by Inst.tcSyntaxName, but is less flexible + than the rest of rebindable syntax, where the type is less + pre-ordained. (And this flexibility is useful; for example we can + typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) -------------------------- + +\begin{code} -- | A Haskell expression. data HsExpr id = HsVar id -- ^ variable @@ -111,9 +133,9 @@ data HsExpr id | HsLit HsLit -- ^ Simple (non-overloaded) literals - | HsLam (MatchGroup id) -- Currently always a single match + | HsLam (MatchGroup id (LHsExpr id)) -- Currently always a single match - | HsLamCase PostTcType (MatchGroup id) -- Lambda-case + | HsLamCase PostTcType (MatchGroup id (LHsExpr id)) -- Lambda-case | HsApp (LHsExpr id) (LHsExpr id) -- Application @@ -143,7 +165,7 @@ data HsExpr id Boxity | HsCase (LHsExpr id) - (MatchGroup id) + (MatchGroup id (LHsExpr id)) | HsIf (Maybe (SyntaxExpr id)) -- cond function -- Nothing => use the built-in 'if' @@ -152,7 +174,7 @@ data HsExpr id (LHsExpr id) -- then part (LHsExpr id) -- else part - | HsMultiIf PostTcType [LGRHS id] -- Multi-way if + | HsMultiIf PostTcType [LGRHS id (LHsExpr id)] -- Multi-way if | HsLet (HsLocalBinds id) -- let(rec) (LHsExpr id) @@ -160,7 +182,7 @@ data HsExpr id | HsDo (HsStmtContext Name) -- The parameterisation is unimportant -- because in this context we never use -- the PatGuard or ParStmt variant - [LStmt id] -- "do":one or more stmts + [ExprLStmt id] -- "do":one or more stmts PostTcType -- Type of the whole expression | ExplicitList -- syntactic list @@ -238,7 +260,8 @@ data HsExpr id --------------------------------------- -- The following are commands, not expressions proper - + -- They are only used in the parsing stage and are removed + -- immediately in parser.RdrHsSyn.checkCommand | HsArrApp -- Arrow tail, or arrow application (f -< arg) (LHsExpr id) -- arrow expression, f (LHsExpr id) -- input expression, arg @@ -256,7 +279,6 @@ data HsExpr id -- were converted from OpApp's by the renamer [LHsCmdTop id] -- argument commands - --------------------------------------- -- Haskell program coverage (Hpc) Support @@ -294,6 +316,7 @@ data HsExpr id | HsWrap HsWrapper -- TRANSLATION (HsExpr id) + | HsHole deriving (Data, Typeable) -- HsTupArg is used for tuple sections @@ -557,17 +580,11 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] ppr_expr (HsArrForm op _ args) - = hang (ptext (sLit "(|") <> ppr_lexpr op) - 4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)")) + = hang (ptext (sLit "(|") <+> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)")) +ppr_expr HsHole + = ptext $ sLit "_" -pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc -pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _) - = ppr_lexpr cmd -pprCmdArg (HsCmdTop cmd _ _ _) - = parens (ppr_lexpr cmd) - -instance OutputableBndr id => Outputable (HsCmdTop id) where - ppr = pprCmdArg \end{code} HsSyn records exactly where the user put parens, with HsPar. @@ -634,52 +651,52 @@ isAtomicHsExpr _ = False We re-use HsExpr to represent these. \begin{code} -type HsCmd id = HsExpr id - -type LHsCmd id = LHsExpr id +type LHsCmd id = Located (HsCmd id) -data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp - deriving (Data, Typeable) -\end{code} - -The legal constructors for commands are: - - = HsArrApp ... -- as above +data HsCmd id + = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg + PostTcType -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) - | HsArrForm ... -- as above + | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) + (LHsExpr id) -- the operator + -- after type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + (Maybe Fixity) -- fixity (filled in by the renamer), for forms that + -- were converted from OpApp's by the renamer + [LHsCmdTop id] -- argument commands + + | HsCmdApp (LHsCmd id) + (LHsExpr id) - | HsApp (HsCmd id) - (HsExpr id) + | HsCmdLam (MatchGroup id (LHsCmd id)) -- kappa - | HsLam (Match id) -- kappa + | HsCmdPar (LHsCmd id) -- parenthesised command - -- the renamer turns this one into HsArrForm - | OpApp (HsExpr id) -- left operand - (HsCmd id) -- operator - Fixity -- Renamer adds fixity; bottom until then - (HsCmd id) -- right operand + | HsCmdCase (LHsExpr id) + (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's - | HsPar (HsCmd id) -- parenthesised command + | HsCmdIf (Maybe (SyntaxExpr id)) -- cond function + (LHsExpr id) -- predicate + (LHsCmd id) -- then part + (LHsCmd id) -- else part - | HsCase (HsExpr id) - [Match id] -- bodies are HsCmd's - SrcLoc + | HsCmdLet (HsLocalBinds id) -- let(rec) + (LHsCmd id) - | HsIf (Maybe (SyntaxExpr id)) -- cond function - (HsExpr id) -- predicate - (HsCmd id) -- then part - (HsCmd id) -- else part - SrcLoc + | HsCmdDo [CmdLStmt id] + PostTcType -- Type of the whole expression + deriving (Data, Typeable) - | HsLet (HsLocalBinds id) -- let(rec) - (HsCmd id) +data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp + deriving (Data, Typeable) - | HsDo (HsStmtContext Name) -- The parameterisation is unimportant - -- because in this context we never use - -- the PatGuard or ParStmt variant - [Stmt id] -- HsExpr's are really HsCmd's - PostTcType -- Type of the whole expression - SrcLoc +\end{code} Top-level command, introducing a new arrow. This may occur inside a proc (where the stack is empty) or as an @@ -690,13 +707,102 @@ type LHsCmdTop id = Located (HsCmdTop id) data HsCmdTop id = HsCmdTop (LHsCmd id) - [PostTcType] -- types of inputs on the command's stack - PostTcType -- return type of the command - (SyntaxTable id) -- after type checking: - -- names used in the command's desugaring + [PostTcType] -- types of inputs on the command's stack + PostTcType -- return type of the command + (CmdSyntaxTable id) -- See Note [CmdSyntaxTable] deriving (Data, Typeable) \end{code} + +\begin{code} +instance OutputableBndr id => Outputable (HsCmd id) where + ppr cmd = pprCmd cmd + +----------------------- +-- pprCmd and pprLCmd call pprDeeper; +-- the underscore versions do not +pprLCmd :: OutputableBndr id => LHsCmd id -> SDoc +pprLCmd (L _ c) = pprCmd c + +pprCmd :: OutputableBndr id => HsCmd id -> SDoc +pprCmd c | isQuietHsCmd c = ppr_cmd c + | otherwise = pprDeeper (ppr_cmd c) + +isQuietHsCmd :: HsCmd id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsCmd (HsCmdPar _) = True +-- applications don't display anything themselves +isQuietHsCmd (HsCmdApp _ _) = True +isQuietHsCmd _ = False + +----------------------- +ppr_lcmd :: OutputableBndr id => LHsCmd id -> SDoc +ppr_lcmd c = ppr_cmd (unLoc c) + +ppr_cmd :: forall id. OutputableBndr id => HsCmd id -> SDoc +ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) + +ppr_cmd (HsCmdApp c e) + = let (fun, args) = collect_args c [e] in + hang (ppr_lcmd fun) 2 (sep (map pprParendExpr args)) + where + collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +--avoid using PatternSignatures for stage1 code portability +ppr_cmd (HsCmdLam matches) + = pprMatches (LambdaExpr :: HsMatchContext id) matches + +ppr_cmd (HsCmdCase expr matches) + = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")], + nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] + +ppr_cmd (HsCmdIf _ e ct ce) + = sep [hsep [ptext (sLit "if"), nest 2 (ppr e), ptext (sLit "then")], + nest 4 (ppr ct), + ptext (sLit "else"), + nest 4 (ppr ce)] + +-- special case: let ... in let ... +ppr_cmd (HsCmdLet binds cmd@(L _ (HsCmdLet _ _))) + = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]), + ppr_lcmd cmd] + +ppr_cmd (HsCmdLet binds cmd) + = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), + hang (ptext (sLit "in")) 2 (ppr cmd)] + +ppr_cmd (HsCmdDo stmts _) = pprDo ArrowExpr stmts + + +ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg] +ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False) + = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow] +ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg] +ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) + = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow] + +ppr_cmd (HsCmdArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) + = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] +ppr_cmd (HsCmdArrForm op _ args) + = hang (ptext (sLit "(|") <> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)")) + +pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc +pprCmdArg (HsCmdTop cmd@(L _ (HsCmdArrForm _ Nothing [])) _ _ _) + = ppr_lcmd cmd +pprCmdArg (HsCmdTop cmd _ _ _) + = parens (ppr_lcmd cmd) + +instance OutputableBndr id => Outputable (HsCmdTop id) where + ppr = pprCmdArg + +\end{code} + %************************************************************************ %* * \subsection{Record binds} @@ -729,28 +835,28 @@ a function defined by pattern matching must have the same number of patterns in each equation. \begin{code} -data MatchGroup id +data MatchGroup id body = MatchGroup - [LMatch id] -- The alternatives - PostTcType -- The type is the type of the entire group - -- t1 -> ... -> tn -> tr - -- where there are n patterns + [LMatch id body] -- The alternatives + PostTcType -- The type is the type of the entire group + -- t1 -> ... -> tn -> tr + -- where there are n patterns deriving (Data, Typeable) -type LMatch id = Located (Match id) +type LMatch id body = Located (Match id body) -data Match id +data Match id body = Match [LPat id] -- The patterns (Maybe (LHsType id)) -- A type signature for the result of the match -- Nothing after typechecking - (GRHSs id) + (GRHSs id body) deriving (Data, Typeable) -isEmptyMatchGroup :: MatchGroup id -> Bool +isEmptyMatchGroup :: MatchGroup id body -> Bool isEmptyMatchGroup (MatchGroup ms _) = null ms -matchGroupArity :: MatchGroup id -> Arity +matchGroupArity :: MatchGroup id body -> Arity matchGroupArity (MatchGroup [] _) = panic "matchGroupArity" -- Precondition: MatchGroup is non-empty matchGroupArity (MatchGroup (match:matches) _) @@ -760,43 +866,46 @@ matchGroupArity (MatchGroup (match:matches) _) where n_pats = length (hsLMatchPats match) -hsLMatchPats :: LMatch id -> [LPat id] +hsLMatchPats :: LMatch id body -> [LPat id] hsLMatchPats (L _ (Match pats _ _)) = pats -- | GRHSs are used both for pattern bindings and for Matches -data GRHSs id +data GRHSs id body = GRHSs { - grhssGRHSs :: [LGRHS id], -- ^ Guarded RHSs + grhssGRHSs :: [LGRHS id body], -- ^ Guarded RHSs grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause } deriving (Data, Typeable) -type LGRHS id = Located (GRHS id) +type LGRHS id body = Located (GRHS id body) -- | Guarded Right Hand Side. -data GRHS id = GRHS [LStmt id] -- Guards - (LHsExpr id) -- Right hand side +data GRHS id body = GRHS [GuardLStmt id] -- Guards + body -- Right hand side deriving (Data, Typeable) \end{code} We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc +pprMatches :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> MatchGroup idR body -> SDoc pprMatches ctxt (MatchGroup matches _) = vcat (map (pprMatch ctxt) (map unLoc matches)) -- Don't print the type; it's only a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => idL -> Bool -> MatchGroup idR -> SDoc +pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => idL -> Bool -> MatchGroup idR body -> SDoc pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr id. (OutputableBndr bndr, OutputableBndr id) - => LPat bndr -> GRHSs id -> SDoc +pprPatBind :: forall bndr id body. (OutputableBndr bndr, OutputableBndr id, Outputable body) + => LPat bndr -> GRHSs id body -> SDoc pprPatBind pat (grhss) = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)] -pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc +pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> Match idR body -> SDoc pprMatch ctxt (Match pats maybe_ty grhss) = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) , nest 2 ppr_maybe_ty @@ -830,23 +939,22 @@ pprMatch ctxt (Match pats maybe_ty grhss) Nothing -> empty -pprGRHSs :: (OutputableBndr idL, OutputableBndr idR) - => HsMatchContext idL -> GRHSs idR -> SDoc +pprGRHSs :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> GRHSs idR body -> SDoc pprGRHSs ctxt (GRHSs grhss binds) = vcat (map (pprGRHS ctxt . unLoc) grhss) $$ ppUnless (isEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) -pprGRHS :: (OutputableBndr idL, OutputableBndr idR) - => HsMatchContext idL -> GRHS idR -> SDoc +pprGRHS :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> GRHS idR body -> SDoc +pprGRHS ctxt (GRHS [] body) + = pp_rhs ctxt body -pprGRHS ctxt (GRHS [] expr) - = pp_rhs ctxt expr +pprGRHS ctxt (GRHS guards body) + = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt body] -pprGRHS ctxt (GRHS guards expr) - = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr] - -pp_rhs :: OutputableBndr idR => HsMatchContext idL -> LHsExpr idR -> SDoc +pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) \end{code} @@ -857,30 +965,40 @@ pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) %************************************************************************ \begin{code} -type LStmt id = Located (StmtLR id id) -type LStmtLR idL idR = Located (StmtLR idL idR) +type LStmt id body = Located (StmtLR id id body) +type LStmtLR idL idR body = Located (StmtLR idL idR body) + +type Stmt id body = StmtLR id id body + +type CmdLStmt id = LStmt id (LHsCmd id) +type CmdStmt id = Stmt id (LHsCmd id) +type ExprLStmt id = LStmt id (LHsExpr id) +type ExprStmt id = Stmt id (LHsExpr id) -type Stmt id = StmtLR id id +type GuardLStmt id = LStmt id (LHsExpr id) +type GuardStmt id = Stmt id (LHsExpr id) +type GhciLStmt id = LStmt id (LHsExpr id) +type GhciStmt id = Stmt id (LHsExpr id) -- The SyntaxExprs in here are used *only* for do-notation and monad -- comprehensions, which have rebindable syntax. Otherwise they are unused. -data StmtLR idL idR +data StmtLR idL idR body -- body should always be (LHs**** idR) = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp, -- and (after the renamer) DoExpr, MDoExpr - -- Not used for GhciStmt, PatGuard, which scope over other stuff - (LHsExpr idR) + -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff + body (SyntaxExpr idR) -- The return operator, used only for MonadComp -- For ListComp, PArrComp, we use the baked-in 'return' -- For DoExpr, MDoExpr, we don't appply a 'return' at all -- See Note [Monad Comprehensions] | BindStmt (LPat idL) - (LHsExpr idR) + body (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind] (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail - | ExprStmt (LHsExpr idR) -- See Note [ExprStmt] + | BodyStmt body -- See Note [BodyStmt] (SyntaxExpr idR) -- The (>>) operator (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp -- See notes [Monad Comprehensions] @@ -898,13 +1016,13 @@ data StmtLR idL idR | TransStmt { trS_form :: TransForm, - trS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group' + trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' -- which generates the tuples to be grouped - trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map] + trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map] trS_using :: LHsExpr idR, - trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) + trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) -- Invariant: if trS_form = GroupBy, then grp_by = Just e trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for @@ -916,7 +1034,7 @@ data StmtLR idL idR -- Recursive statement (see Note [How RecStmt works] below) | RecStmt - { recS_stmts :: [LStmtLR idL idR] + { recS_stmts :: [LStmtLR idL idR body] -- The next two fields are only valid after renaming , recS_later_ids :: [idR] -- The ids are a subset of the variables bound by the @@ -958,7 +1076,7 @@ data TransForm -- The 'f' below is the 'using' function, 'e' is the by function data ParStmtBlock idL idR = ParStmtBlock - [LStmt idL] + [ExprLStmt idL] [idR] -- The variables to be returned (SyntaxExpr idR) -- The return operator deriving( Data, Typeable ) @@ -993,20 +1111,20 @@ The [(idR,idR)] in a TransStmt behaves as follows: [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] Each pair has the same unique, but different *types*. -Note [ExprStmt] +Note [BodyStmt] ~~~~~~~~~~~~~~~ -ExprStmts are a bit tricky, because what they mean +BodyStmts are a bit tricky, because what they mean depends on the context. Consider the following contexts: A do expression of type (m res_ty) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * ExprStmt E any_ty: do { ....; E; ... } + * BodyStmt E any_ty: do { ....; E; ... } E :: m any_ty Translation: E >> ... A list comprehensions of type [elt_ty] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * ExprStmt E Bool: [ .. | .... E ] + * BodyStmt E Bool: [ .. | .... E ] [ .. | ..., E, ... ] [ .. | .... | ..., E | ... ] E :: Bool @@ -1014,13 +1132,13 @@ depends on the context. Consider the following contexts: A guard list, guarding a RHS of type rhs_ty ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * ExprStmt E Bool: f x | ..., E, ... = ...rhs... + * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... E :: Bool Translation: if E then fail else ... A monad comprehension of type (m res_ty) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * ExprStmt E Bool: [ .. | .... E ] + * BodyStmt E Bool: [ .. | .... E ] E :: Bool Translation: guard E >> ... @@ -1083,7 +1201,7 @@ In transform and grouping statements ('then ..' and 'then group ..') the => f [ env | stmts ] >>= \bndrs -> [ body | rest ] -ExprStmts require the 'Control.Monad.guard' function for boolean +BodyStmts require the 'Control.Monad.guard' function for boolean expressions: [ body | exp, stmts ] @@ -1102,17 +1220,19 @@ In any other context than 'MonadComp', the fields for most of these \begin{code} instance (OutputableBndr idL, OutputableBndr idR) - => Outputable (ParStmtBlock idL idR) where + => Outputable (ParStmtBlock idL idR) where ppr (ParStmtBlock stmts _ _) = interpp'SP stmts -instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where +instance (OutputableBndr idL, OutputableBndr idR, Outputable body) + => Outputable (StmtLR idL idR body) where ppr stmt = pprStmt stmt -pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc +pprStmt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr] pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] -pprStmt (ExprStmt expr _ _ _) = ppr expr +pprStmt (BodyStmt expr _ _ _) = ppr expr pprStmt (ParStmt stmtss _ _) = sep (punctuate (ptext (sLit " | ")) (map ppr stmtss)) pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form }) @@ -1131,36 +1251,37 @@ pprTransformStmt bndrs using by , nest 2 (ppr using) , nest 2 (pprBy by)] -pprTransStmt :: OutputableBndr id => Maybe (LHsExpr id) - -> LHsExpr id -> TransForm - -> SDoc +pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc pprTransStmt by using ThenForm = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)] pprTransStmt by using GroupForm = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] -pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc +pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = ptext (sLit "by") <+> ppr e -pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc -pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts -pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts -pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts -pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts -pprDo ListComp stmts = brackets $ pprComp stmts -pprDo PArrComp stmts = paBrackets $ pprComp stmts -pprDo MonadComp stmts = brackets $ pprComp stmts -pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt - -ppr_do_stmts :: (OutputableBndr idL, OutputableBndr idR) => [LStmtLR idL idR] -> SDoc +pprDo :: (OutputableBndr id, Outputable body) + => HsStmtContext any -> [LStmt id body] -> SDoc +pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo GhciStmtCtxt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts +pprDo ListComp stmts = brackets $ pprComp stmts +pprDo PArrComp stmts = paBrackets $ pprComp stmts +pprDo MonadComp stmts = brackets $ pprComp stmts +pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt + +ppr_do_stmts :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => [LStmtLR idL idR body] -> SDoc -- Print a bunch of do stmts, with explicit braces and semicolons, -- so that we are not vulnerable to layout bugs ppr_do_stmts stmts = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts)) <+> rbrace -pprComp :: OutputableBndr id => [LStmt id] -> SDoc +pprComp :: (OutputableBndr id, Outputable body) + => [LStmt id body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | not (null quals) , L _ (LastStmt body _) <- last quals @@ -1168,7 +1289,8 @@ pprComp quals -- Prints: body | qual1, ..., qualn | otherwise = pprPanic "pprComp" (pprQuals quals) -pprQuals :: OutputableBndr id => [LStmt id] -> SDoc +pprQuals :: (OutputableBndr id, Outputable body) + => [LStmt id body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals \end{code} @@ -1294,7 +1416,7 @@ data HsStmtContext id | MDoExpr -- mdo { ... } ie recursive do-expression | ArrowExpr -- do-notation in an arrow-command context - | GhciStmt -- A command-line Stmt in GHCi pat <- rhs + | GhciStmtCtxt -- A command-line Stmt in GHCi pat <- rhs | PatGuard (HsMatchContext id) -- Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt | TransStmtCtxt (HsStmtContext id) -- A branch of a transform stmt @@ -1361,14 +1483,14 @@ pprAStmtContext ctxt = article <+> pprStmtContext ctxt pp_an = ptext (sLit "an") pp_a = ptext (sLit "a") article = case ctxt of - MDoExpr -> pp_an - PArrComp -> pp_an - GhciStmt -> pp_an - _ -> pp_a + MDoExpr -> pp_an + PArrComp -> pp_an + GhciStmtCtxt -> pp_an + _ -> pp_a ----------------- -pprStmtContext GhciStmt = ptext (sLit "interactive GHCi command") +pprStmtContext GhciStmtCtxt = ptext (sLit "interactive GHCi command") pprStmtContext DoExpr = ptext (sLit "'do' block") pprStmtContext MDoExpr = ptext (sLit "'mdo' block") pprStmtContext ArrowExpr = ptext (sLit "'do' block in an arrow command") @@ -1403,7 +1525,7 @@ matchContextErrString ThPatQuote = panic "matchContextErrString" matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") -matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") +matchContextErrString (StmtCtxt GhciStmtCtxt) = ptext (sLit "interactive GHCi command") matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' block") matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block") matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block") @@ -1413,13 +1535,13 @@ matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehe \end{code} \begin{code} -pprMatchInCtxt :: (OutputableBndr idL, OutputableBndr idR) - => HsMatchContext idL -> Match idR -> SDoc +pprMatchInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> Match idR body -> SDoc pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match) -pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR) - => HsStmtContext idL -> StmtLR idL idR -> SDoc +pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsStmtContext idL -> StmtLR idL idR body -> SDoc pprStmtInCtxt ctxt (LastStmt e _) | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" = hang (ptext (sLit "In the expression:")) 2 (ppr e) diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot index 86032f5829..a04fa3095b 100644 --- a/compiler/hsSyn/HsExpr.lhs-boot +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -3,25 +3,31 @@ module HsExpr where import SrcLoc ( Located ) -import Outputable ( SDoc, OutputableBndr ) +import Outputable ( SDoc, OutputableBndr, Outputable ) import {-# SOURCE #-} HsPat ( LPat ) import Data.Data -- IA0_NOTE: We need kind annotations because of kind polymorphism data HsExpr (i :: *) +data HsCmd (i :: *) data HsSplice (i :: *) -data MatchGroup (a :: *) -data GRHSs (a :: *) +data MatchGroup (a :: *) (body :: *) +data GRHSs (a :: *) (body :: *) instance Typeable1 HsSplice instance Data i => Data (HsSplice i) instance Typeable1 HsExpr instance Data i => Data (HsExpr i) -instance Typeable1 MatchGroup -instance Data i => Data (MatchGroup i) -instance Typeable1 GRHSs -instance Data i => Data (GRHSs i) +instance Typeable1 HsCmd +instance Data i => Data (HsCmd i) +instance Typeable2 MatchGroup +instance (Data i, Data body) => Data (MatchGroup i body) +instance Typeable2 GRHSs +instance (Data i, Data body) => Data (GRHSs i body) + +instance OutputableBndr id => Outputable (HsExpr id) +instance OutputableBndr id => Outputable (HsCmd id) type LHsExpr a = Located (HsExpr a) type SyntaxExpr a = HsExpr a @@ -35,9 +41,9 @@ pprExpr :: (OutputableBndr i) => pprSplice :: (OutputableBndr i) => HsSplice i -> SDoc -pprPatBind :: (OutputableBndr b, OutputableBndr i) => - LPat b -> GRHSs i -> SDoc +pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body) + => LPat bndr -> GRHSs id body -> SDoc -pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => - idL -> Bool -> MatchGroup idR -> SDoc +pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => idL -> Bool -> MatchGroup idR body -> SDoc \end{code} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 32fe487609..087ecd2985 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -50,7 +50,7 @@ module HsUtils( nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, -- Stmts - mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt, + mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt, emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, emptyRecStmt, mkRecStmt, @@ -112,7 +112,7 @@ just attach noSrcSpan to everything. mkHsPar :: LHsExpr id -> LHsExpr id mkHsPar e = L (getLoc e) (HsPar e) -mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id +mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id)) mkSimpleMatch pats rhs = L loc $ Match pats Nothing (unguardedGRHSs rhs) @@ -121,13 +121,13 @@ mkSimpleMatch pats rhs [] -> getLoc rhs (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) -unguardedGRHSs :: LHsExpr id -> GRHSs id +unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id)) unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds -unguardedRHS :: LHsExpr id -> [LGRHS id] +unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))] unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)] -mkMatchGroup :: [LMatch id] -> MatchGroup id +mkMatchGroup :: [LMatch id (Located (body id))] -> MatchGroup id (Located (body id)) mkMatchGroup matches = MatchGroup matches placeHolderType mkHsAppTy :: LHsType name -> LHsType name -> LHsType name @@ -139,7 +139,7 @@ mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) where - matches = mkMatchGroup [mkSimpleMatch pats body] + matches = mkMatchGroup [mkSimpleMatch pats body] mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr @@ -151,7 +151,7 @@ mkHsConApp data_con tys args where mk_app f a = noLoc (HsApp f (noLoc a)) -mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id +mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking mkSimpleHsAlt pat expr = mkSimpleMatch [pat] expr @@ -178,18 +178,18 @@ mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp) mkHsIntegral :: Integer -> PostTcType -> HsOverLit id mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id mkHsIsString :: FastString -> PostTcType -> HsOverLit id -mkHsDo :: HsStmtContext Name -> [LStmt id] -> HsExpr id -mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id +mkHsDo :: HsStmtContext Name -> [ExprLStmt id] -> HsExpr id +mkHsComp :: HsStmtContext Name -> [ExprLStmt id] -> LHsExpr id -> HsExpr id mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id mkNPlusKPat :: Located id -> HsOverLit id -> Pat id -mkLastStmt :: LHsExpr idR -> StmtLR idL idR -mkExprStmt :: LHsExpr idR -> StmtLR idL idR -mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR +mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) +mkBodyStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) +mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) -emptyRecStmt :: StmtLR idL idR -mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR +emptyRecStmt :: StmtLR idL idR bodyR +mkRecStmt :: [LStmtLR idL idR bodyR] -> StmtLR idL idR bodyR mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr @@ -210,12 +210,16 @@ mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b mkNPat lit neg = NPat lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr -mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR -mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR -mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR -mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR +mkTransformStmt :: [ExprLStmt idL] -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkTransformByStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkGroupUsingStmt :: [ExprLStmt idL] -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkGroupByUsingStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) -emptyTransStmt :: StmtLR idL idR +emptyTransStmt :: StmtLR idL idR (LHsExpr idR) emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] , trS_by = Nothing, trS_using = noLoc noSyntaxExpr @@ -226,9 +230,9 @@ mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = s mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } -mkLastStmt expr = LastStmt expr noSyntaxExpr -mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType -mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr +mkLastStmt body = LastStmt body noSyntaxExpr +mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType +mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr @@ -324,16 +328,16 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) nlWildPat :: LPat id nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking -nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id +nlHsDo :: HsStmtContext Name -> [LStmt id (LHsExpr id)] -> LHsExpr id nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) -nlHsLam :: LMatch id -> LHsExpr id +nlHsLam :: LMatch id (LHsExpr id) -> LHsExpr id nlHsPar :: LHsExpr id -> LHsExpr id nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id -nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id +nlHsCase :: LHsExpr id -> [LMatch id (LHsExpr id)] -> LHsExpr id nlList :: [LHsExpr id] -> LHsExpr id nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) @@ -413,7 +417,7 @@ l %************************************************************************ \begin{code} -mkFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName +mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName -- Not infix, with place holders for coercion and free vars mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False , fun_matches = mkMatchGroup ms @@ -421,7 +425,7 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False , bind_fvs = placeHolderNames , fun_tick = Nothing } -mkTopFunBind :: Located Name -> [LMatch Name] -> HsBind Name +mkTopFunBind :: Located Name -> [LMatch Name (LHsExpr Name)] -> HsBind Name -- In Name-land, with empty bind_fvs mkTopFunBind fn ms = FunBind { fun_id = fn, fun_infix = False , fun_matches = mkMatchGroup ms @@ -443,7 +447,7 @@ mk_easy_FunBind loc fun pats expr = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds] ------------ -mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id +mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id) mkMatch pats expr binds = noLoc (Match (map paren pats) Nothing (GRHSs (unguardedRHS expr) binds)) @@ -521,20 +525,20 @@ collectMethodBinders binds = foldrBag get [] binds -- Someone else complains about non-FunBinds ----------------- Statements -------------------------- -collectLStmtsBinders :: [LStmtLR idL idR] -> [idL] +collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: [StmtLR idL idR] -> [idL] +collectStmtsBinders :: [StmtLR idL idR body] -> [idL] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: LStmtLR idL idR -> [idL] +collectLStmtBinders :: LStmtLR idL idR body -> [idL] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: StmtLR idL idR -> [idL] +collectStmtBinders :: StmtLR idL idR body -> [idL] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (LetStmt binds) = collectLocalBinders binds -collectStmtBinders (ExprStmt {}) = [] +collectStmtBinders (BodyStmt {}) = [] collectStmtBinders (LastStmt {}) = [] collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders $ [s | ParStmtBlock ss _ _ <- xs, s <- ss] @@ -702,15 +706,15 @@ The main purpose is to find names introduced by record wildcards so that we can warning the user when they don't use those names (#4404) \begin{code} -lStmtsImplicits :: [LStmtLR Name idR] -> NameSet +lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet lStmtsImplicits = hs_lstmts where - hs_lstmts :: [LStmtLR Name idR] -> NameSet + hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat hs_stmt (LetStmt binds) = hs_local_binds binds - hs_stmt (ExprStmt {}) = emptyNameSet + hs_stmt (BodyStmt {}) = emptyNameSet hs_stmt (LastStmt {}) = emptyNameSet hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index a319f6ed62..616bc0acf4 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -20,11 +20,12 @@ module BinIface ( #include "HsVersions.h" import TcRnMonad -import TyCon (TyCon, tyConName, tupleTyConSort, tupleTyConArity, isTupleTyCon) +import TyCon import DataCon (dataConName, dataConWorkId, dataConTyCon) import PrelInfo (wiredInThings, basicKnownKeyNames) import Id (idName, isDataConWorkId_maybe) import CoreSyn (DFunArg(..)) +import Coercion (LeftOrRight(..)) import TysWiredIn import IfaceEnv import HscTypes @@ -1037,6 +1038,15 @@ instance Binary IfaceTyCon where put_ bh (IfaceTc ext) = put_ bh ext get bh = liftM IfaceTc (get bh) +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } + instance Binary IfaceCoCon where put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } put_ bh IfaceReflCo = putByte bh 1 @@ -1045,6 +1055,7 @@ instance Binary IfaceCoCon where put_ bh IfaceTransCo = putByte bh 4 put_ bh IfaceInstCo = putByte bh 5 put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } + put_ bh (IfaceLRCo lr) = do { putByte bh 7; put_ bh lr } get bh = do h <- getByte bh @@ -1056,6 +1067,7 @@ instance Binary IfaceCoCon where 4 -> return IfaceTransCo 5 -> return IfaceInstCo 6 -> do { d <- get bh; return (IfaceNthCo d) } + 7 -> do { lr <- get bh; return (IfaceLRCo lr) } _ -> panic ("get IfaceCoCon " ++ show h) ------------------------------------------------------------------------- @@ -1392,6 +1404,18 @@ instance Binary IfaceDecl where occ <- return $! mkOccNameFS tcName a1 return (IfaceAxiom occ a2 a3 a4) +instance Binary ty => Binary (SynTyConRhs ty) where + put_ bh (SynFamilyTyCon a b) = putByte bh 0 >> put_ bh a >> put_ bh b + put_ bh (SynonymTyCon ty) = putByte bh 1 >> put_ bh ty + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { a <- get bh + ; b <- get bh + ; return (SynFamilyTyCon a b) } + _ -> do { ty <- get bh + ; return (SynonymTyCon ty) } } + instance Binary IfaceClsInst where put_ bh (IfaceClsInst cls tys dfun flag orph) = do put_ bh cls diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 9456bdaf34..5f5e8a1896 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -46,7 +46,7 @@ import Outputable \begin{code} ------------------------------------------------------ buildSynTyCon :: Name -> [TyVar] - -> SynTyConRhs + -> SynTyConRhs Type -> Kind -- ^ Kind of the RHS -> TyConParent -> TcRnIf m n TyCon diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index a41a9dac47..06c7b67ba6 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -35,6 +35,7 @@ module IfaceSyn ( #include "HsVersions.h" +import TyCon( SynTyConRhs(..) ) import IfaceType import CoreSyn( DFunArg, dfunArgExprs ) import PprCore() -- Printing DFunArgs @@ -89,9 +90,7 @@ data IfaceDecl | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) - ifSynRhs :: Maybe IfaceType -- Just rhs for an ordinary synonyn - -- Nothing for an type family declaration - } + ifSynRhs :: SynTyConRhs IfaceType } | IfaceClass { ifCtxt :: IfaceContext, -- Context... ifName :: OccName, -- Name of the class TyCon @@ -487,12 +486,12 @@ pprIfaceDecl (IfaceForeign {ifName = tycon}) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Just mono_ty}) + ifSynRhs = SynonymTyCon mono_ty}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty]) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Nothing, ifSynKind = kind }) + ifSynRhs = SynFamilyTyCon {}, ifSynKind = kind }) = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) 4 (dcolon <+> ppr kind) @@ -797,9 +796,9 @@ freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc freeNamesIfIdDetails _ = emptyNameSet -- All other changes are handled via the version info on the tycon -freeNamesIfSynRhs :: Maybe IfaceType -> NameSet -freeNamesIfSynRhs (Just ty) = freeNamesIfType ty -freeNamesIfSynRhs Nothing = emptyNameSet +freeNamesIfSynRhs :: SynTyConRhs IfaceType -> NameSet +freeNamesIfSynRhs (SynonymTyCon ty) = freeNamesIfType ty +freeNamesIfSynRhs _ = emptyNameSet freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 225a3c812b..4a35f0049b 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -99,7 +99,7 @@ data IfaceCoCon = IfaceCoAx IfExtName | IfaceReflCo | IfaceUnsafeCo | IfaceSymCo | IfaceTransCo | IfaceInstCo - | IfaceNthCo Int + | IfaceNthCo Int | IfaceLRCo LeftOrRight \end{code} %************************************************************************ @@ -278,6 +278,7 @@ instance Outputable IfaceCoCon where ppr IfaceTransCo = ptext (sLit "Trans") ppr IfaceInstCo = ptext (sLit "Inst") ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d + ppr (IfaceLRCo lr) = ppr lr instance Outputable IfaceTyLit where ppr = ppr_tylit @@ -376,6 +377,8 @@ coToIfaceType (TransCo co1 co2) = IfaceCoConApp IfaceTransCo , coToIfaceType co2 ] coToIfaceType (NthCo d co) = IfaceCoConApp (IfaceNthCo d) [ coToIfaceType co ] +coToIfaceType (LRCo lr co) = IfaceCoConApp (IfaceLRCo lr) + [ coToIfaceType co ] coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo [ coToIfaceType co , toIfaceType ty ] diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index d92cb4a185..a4a9dfc5f6 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1459,11 +1459,11 @@ tyConToIfaceDecl env tycon | Just clas <- tyConClass_maybe tycon = classToIfaceDecl env clas - | isSynTyCon tycon + | Just syn_rhs <- synTyConRhs_maybe tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifSynRhs = syn_rhs, - ifSynKind = syn_ki } + ifSynRhs = to_ifsyn_rhs syn_rhs, + ifSynKind = tidyToIfaceType env1 (synTyConResKind tycon) } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, @@ -1483,18 +1483,12 @@ tyConToIfaceDecl env tycon where (env1, tyvars) = tidyTyVarBndrs env (tyConTyVars tycon) - (syn_rhs, syn_ki) - = case synTyConRhs tycon of - SynFamilyTyCon -> - ( Nothing - , tidyToIfaceType env1 (synTyConResKind tycon) ) - SynonymTyCon ty -> - ( Just (tidyToIfaceType env1 ty) - , tidyToIfaceType env1 (typeKind ty) ) + to_ifsyn_rhs (SynFamilyTyCon a b) = SynFamilyTyCon a b + to_ifsyn_rhs (SynonymTyCon ty) = SynonymTyCon (tidyToIfaceType env1 ty) ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls DataFamilyTyCon {} = IfDataFamTyCon + ifaceConDecls (DataFamilyTyCon {}) = IfDataFamTyCon ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct -- The last case happens when a TyCon has been trimmed during tidying -- Furthermore, tyThingToIfaceDecl is also used diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 80c2029a70..b9783a8d4f 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -474,9 +474,9 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type syonym") <+> ppr n - tc_syn_rhs Nothing = return SynFamilyTyCon - tc_syn_rhs (Just ty) = do { rhs_ty <- tcIfaceType ty - ; return (SynonymTyCon rhs_ty) } + tc_syn_rhs (SynFamilyTyCon a b) = return (SynFamilyTyCon a b) + tc_syn_rhs (SynonymTyCon ty) = do { rhs_ty <- tcIfaceType ty + ; return (SynonymTyCon rhs_ty) } tc_iface_decl _parent ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, @@ -962,6 +962,7 @@ tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2 tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t +tcIfaceCoApp (IfaceLRCo lr) [t] = LRCo lr <$> tcIfaceCo t tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts) tcIfaceCoVar :: FastString -> IfL CoVar diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 6e51dcf4fa..bbf7b75488 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -512,6 +512,7 @@ data ExtensionFlag | Opt_TraditionalRecordSyntax | Opt_LambdaCase | Opt_MultiWayIf + | Opt_TypeHoles deriving (Eq, Enum, Show) -- | Contains not only a collection of 'DynFlag's but also a plethora of @@ -2437,7 +2438,8 @@ xFlags = [ ( "OverlappingInstances", Opt_OverlappingInstances, nop ), ( "UndecidableInstances", Opt_UndecidableInstances, nop ), ( "IncoherentInstances", Opt_IncoherentInstances, nop ), - ( "PackageImports", Opt_PackageImports, nop ) + ( "PackageImports", Opt_PackageImports, nop ), + ( "TypeHoles", Opt_TypeHoles, nop ) ] defaultFlags :: Settings -> [DynFlag] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index b1cc786840..06b3ecaf23 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -159,7 +159,7 @@ module GHC ( tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, isFamilyTyCon, tyConClass_maybe, - synTyConDefn, synTyConType, synTyConResKind, + synTyConRhs_maybe, synTyConDefn_maybe, synTyConResKind, -- ** Type variables TyVar, diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index f04ca020e2..04f89bf63e 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1611,7 +1611,7 @@ hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv maybe_stmt <- hscParseStmt expr case maybe_stmt of - Just (L _ (ExprStmt expr _ _ _)) -> + Just (L _ (BodyStmt expr _ _ _)) -> ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan @@ -1628,11 +1628,11 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do ty <- hscParseType str ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) normalise ty -hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName)) +hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName)) hscParseStmt = hscParseThing parseStmt hscParseStmtWithLocation :: String -> Int -> String - -> Hsc (Maybe (LStmt RdrName)) + -> Hsc (Maybe (GhciLStmt RdrName)) hscParseStmtWithLocation source linenumber stmt = hscParseThingWithLocation source linenumber parseStmt stmt diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 1ee18f84e3..0fa7bdff52 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -165,13 +165,13 @@ pprTypeForUser print_foralls ty pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc pprTyCon pefas ss tyCon - | GHC.isSynTyCon tyCon - = if GHC.isFamilyTyCon tyCon - then pprTyConHdr pefas tyCon <+> dcolon <+> - pprTypeForUser pefas (GHC.synTyConResKind tyCon) - else - let rhs_type = GHC.synTyConType tyCon - in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type) + | Just syn_rhs <- GHC.synTyConRhs_maybe tyCon + = case syn_rhs of + SynFamilyTyCon {} -> pprTyConHdr pefas tyCon <+> dcolon <+> + pprTypeForUser pefas (GHC.synTyConResKind tyCon) + SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) + 2 (pprTypeForUser pefas rhs_ty) + | Just cls <- GHC.tyConClass_maybe tyCon = pprClass pefas ss cls | otherwise diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 36b32fa45f..aceb67229e 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -131,11 +131,11 @@ isStaticFlag f = "fruntime-types", "fno-pre-inlining", "fno-opt-coercion", + "fno-flat-cache", "fexcess-precision", "fhardwire-lib-paths", "fcpr-off", - "ferror-spans", - "fhpc" + "ferror-spans" ] || any (`isPrefixOf` f) [ "fliberate-case-threshold", diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 3165c6944b..fa4b61e287 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -48,6 +48,7 @@ module StaticFlags ( opt_SimplExcessPrecision, opt_NoOptCoercion, opt_MaxWorkerArgs, + opt_NoFlatCache, -- Unfolding control opt_UF_CreationThreshold, @@ -243,6 +244,9 @@ opt_SimplExcessPrecision = lookUp (fsLit "-fexcess-precision") opt_NoOptCoercion :: Bool opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion") +opt_NoFlatCache :: Bool +opt_NoFlatCache = lookUp (fsLit "-fno-flat-cache") + -- Unfolding control -- See Note [Discounts and thresholds] in CoreUnfold diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 718adcabfd..966d4e3613 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1334,15 +1334,15 @@ decl :: { Located (OrdList (LHsDecl RdrName)) } return $! (sL l (unitOL $! (sL l $ ValD r))) } } | docdecl { LL $ unitOL $1 } -rhs :: { Located (GRHSs RdrName) } +rhs :: { Located (GRHSs RdrName (LHsExpr RdrName)) } : '=' exp wherebinds { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) } | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) } -gdrhs :: { Located [LGRHS RdrName] } +gdrhs :: { Located [LGRHS RdrName (LHsExpr RdrName)] } : gdrhs gdrh { LL ($2 : unLoc $1) } | gdrh { L1 [$1] } -gdrh :: { LGRHS RdrName } +gdrh :: { LGRHS RdrName (LHsExpr RdrName) } : '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } sigdecl :: { Located (OrdList (LHsDecl RdrName)) } @@ -1422,8 +1422,9 @@ exp10 :: { LHsExpr RdrName } | 'proc' aexp '->' exp {% checkPattern $2 >>= \ p -> - return (LL $ HsProc p (LL $ HsCmdTop $4 [] - placeHolderType undefined)) } + checkCommand $4 >>= \ cmd -> + return (LL $ HsProc p (LL $ HsCmdTop cmd [] + placeHolderType undefined)) } -- TODO: is LL right here? | '{-# CORE' STRING '#-}' exp { LL $ HsCoreAnn (getSTRING $2) $4 } @@ -1516,7 +1517,8 @@ cmdargs :: { [LHsCmdTop RdrName] } | {- empty -} { [] } acmd :: { LHsCmdTop RdrName } - : aexp2 { L1 $ HsCmdTop $1 [] placeHolderType undefined } + : aexp2 {% checkCommand $1 >>= \ cmd -> + return (L1 $ HsCmdTop cmd [] placeHolderType undefined) } cvtopbody :: { [LHsDecl RdrName] } : '{' cvtopdecls0 '}' { $2 } @@ -1592,7 +1594,7 @@ lexps :: { Located [LHsExpr RdrName] } ----------------------------------------------------------------------------- -- List Comprehensions -flattenedpquals :: { Located [LStmt RdrName] } +flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } : pquals { case (unLoc $1) of [qs] -> L1 qs -- We just had one thing in our "parallel" list so @@ -1604,11 +1606,11 @@ flattenedpquals :: { Located [LStmt RdrName] } -- we wrap them into as a ParStmt } -pquals :: { Located [[LStmt RdrName]] } +pquals :: { Located [[LStmt RdrName (LHsExpr RdrName)]] } : squals '|' pquals { L (getLoc $2) (reverse (unLoc $1) : unLoc $3) } | squals { L (getLoc $1) [reverse (unLoc $1)] } -squals :: { Located [LStmt RdrName] } -- In reverse order, because the last +squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, because the last -- one can "grab" the earlier ones : squals ',' transformqual { LL [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))] } | squals ',' qual { LL ($3 : unLoc $1) } @@ -1623,7 +1625,7 @@ squals :: { Located [LStmt RdrName] } -- In reverse order, because the last -- consensus on the syntax, this feature is not being used until we -- get user demand. -transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) } +transformqual :: { Located ([LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName)) } -- Function is applied to a list of stmts *in order* : 'then' exp { LL $ \ss -> (mkTransformStmt ss $2) } | 'then' exp 'by' exp { LL $ \ss -> (mkTransformByStmt ss $2 $4) } @@ -1657,44 +1659,44 @@ parr :: { LHsExpr RdrName } ----------------------------------------------------------------------------- -- Guards -guardquals :: { Located [LStmt RdrName] } +guardquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) } -guardquals1 :: { Located [LStmt RdrName] } +guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] } : guardquals1 ',' qual { LL ($3 : unLoc $1) } | qual { L1 [$1] } ----------------------------------------------------------------------------- -- Case alternatives -altslist :: { Located [LMatch RdrName] } +altslist :: { Located [LMatch RdrName (LHsExpr RdrName)] } : '{' alts '}' { LL (reverse (unLoc $2)) } | vocurly alts close { L (getLoc $2) (reverse (unLoc $2)) } -alts :: { Located [LMatch RdrName] } +alts :: { Located [LMatch RdrName (LHsExpr RdrName)] } : alts1 { L1 (unLoc $1) } | ';' alts { LL (unLoc $2) } -alts1 :: { Located [LMatch RdrName] } +alts1 :: { Located [LMatch RdrName (LHsExpr RdrName)] } : alts1 ';' alt { LL ($3 : unLoc $1) } | alts1 ';' { LL (unLoc $1) } | alt { L1 [$1] } -alt :: { LMatch RdrName } +alt :: { LMatch RdrName (LHsExpr RdrName) } : pat opt_sig alt_rhs { LL (Match [$1] $2 (unLoc $3)) } -alt_rhs :: { Located (GRHSs RdrName) } +alt_rhs :: { Located (GRHSs RdrName (LHsExpr RdrName)) } : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2)) } -ralt :: { Located [LGRHS RdrName] } +ralt :: { Located [LGRHS RdrName (LHsExpr RdrName)] } : '->' exp { LL (unguardedRHS $2) } | gdpats { L1 (reverse (unLoc $1)) } -gdpats :: { Located [LGRHS RdrName] } +gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] } : gdpats gdpat { LL ($2 : unLoc $1) } | gdpat { L1 [$1] } -gdpat :: { LGRHS RdrName } +gdpat :: { LGRHS RdrName (LHsExpr RdrName) } : '|' guardquals '->' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } -- 'pat' recognises a pattern, including one with a bang at the top @@ -1716,37 +1718,37 @@ apats :: { [LPat RdrName] } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { Located [LStmt RdrName] } +stmtlist :: { Located [LStmt RdrName (LHsExpr RdrName)] } : '{' stmts '}' { LL (unLoc $2) } | vocurly stmts close { $2 } -- do { ;; s ; s ; ; s ;; } -- The last Stmt should be an expression, but that's hard to enforce -- here, because we need too much lookahead if we see do { e ; } --- So we use ExprStmts throughout, and switch the last one over +-- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead -stmts :: { Located [LStmt RdrName] } +stmts :: { Located [LStmt RdrName (LHsExpr RdrName)] } : stmt stmts_help { LL ($1 : unLoc $2) } | ';' stmts { LL (unLoc $2) } | {- empty -} { noLoc [] } -stmts_help :: { Located [LStmt RdrName] } -- might be empty +stmts_help :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- might be empty : ';' stmts { LL (unLoc $2) } | {- empty -} { noLoc [] } -- For typing stmts at the GHCi prompt, where -- the input may consist of just comments. -maybe_stmt :: { Maybe (LStmt RdrName) } +maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) } : stmt { Just $1 } | {- nothing -} { Nothing } -stmt :: { LStmt RdrName } +stmt :: { LStmt RdrName (LHsExpr RdrName) } : qual { $1 } | 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) } -qual :: { LStmt RdrName } +qual :: { LStmt RdrName (LHsExpr RdrName) } : pat '<-' exp { LL $ mkBindStmt $1 $3 } - | exp { L1 $ mkExprStmt $1 } + | exp { L1 $ mkBodyStmt $1 } | 'let' binds { LL $ LetStmt (unLoc $2) } ----------------------------------------------------------------------------- diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 6da712ce44..5c0d3bb700 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -39,6 +39,7 @@ module RdrHsSyn ( bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] checkMonadComp, -- P (HsStmtContext RdrName) + checkCommand, -- LHsExpr RdrName -> P (LHsCmd RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkDoAndIfThenElse, @@ -312,7 +313,7 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, getMonoBind bind binds = (bind, binds) -has_args :: [LMatch RdrName] -> Bool +has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool has_args [] = panic "RdrHsSyn:has_args" has_args ((L _ (Match args _ _)) : _) = not (null args) -- Don't group together FunBinds if they have @@ -637,7 +638,7 @@ patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e) checkValDef :: LHsExpr RdrName -> Maybe (LHsType RdrName) - -> Located (GRHSs RdrName) + -> Located (GRHSs RdrName (LHsExpr RdrName)) -> P (HsBind RdrName) checkValDef lhs (Just sig) grhss @@ -656,7 +657,7 @@ checkFunBind :: SrcSpan -> Bool -> [LHsExpr RdrName] -> Maybe (LHsType RdrName) - -> Located (GRHSs RdrName) + -> Located (GRHSs RdrName (LHsExpr RdrName)) -> P (HsBind RdrName) checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) = do ps <- checkPatterns pats @@ -665,14 +666,14 @@ checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. -makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id +makeFunBind :: Located id -> Bool -> [LMatch id (LHsExpr id)] -> HsBind id -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn is_infix ms = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms, fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing } checkPatBind :: LHsExpr RdrName - -> Located (GRHSs RdrName) + -> Located (GRHSs RdrName (LHsExpr RdrName)) -> P (HsBind RdrName) checkPatBind lhs (L _ grhss) = do { lhs <- checkPattern lhs @@ -808,6 +809,94 @@ checkMonadComp = do then MonadComp else ListComp +-- ------------------------------------------------------------------------- +-- Checking arrow syntax. + +-- We parse arrow syntax as expressions and check for valid syntax below, +-- converting the expression into a pattern at the same time. + +checkCommand :: LHsExpr RdrName -> P (LHsCmd RdrName) +checkCommand lc = locMap checkCmd lc + +locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b) +locMap f (L l a) = f l a >>= (\b -> return $ L l b) + +checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName) +checkCmd _ (HsArrApp e1 e2 ptt haat b) = + return $ HsCmdArrApp e1 e2 ptt haat b +checkCmd _ (HsArrForm e mf args) = + return $ HsCmdArrForm e mf args +checkCmd _ (HsApp e1 e2) = + checkCommand e1 >>= (\c -> return $ HsCmdApp c e2) +checkCmd _ (HsLam mg) = + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg') +checkCmd _ (HsPar e) = + checkCommand e >>= (\c -> return $ HsCmdPar c) +checkCmd _ (HsCase e mg) = + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg') +checkCmd _ (HsIf cf ep et ee) = do + pt <- checkCommand et + pe <- checkCommand ee + return $ HsCmdIf cf ep pt pe +checkCmd _ (HsLet lb e) = + checkCommand e >>= (\c -> return $ HsCmdLet lb c) +checkCmd _ (HsDo DoExpr stmts ty) = + mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo ss ty) + +checkCmd _ (OpApp eLeft op fixity eRight) = do + -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it + c1 <- checkCommand eLeft + c2 <- checkCommand eRight + let arg1 = L (getLoc c1) $ HsCmdTop c1 [] placeHolderType [] + arg2 = L (getLoc c2) $ HsCmdTop c2 [] placeHolderType [] + return $ HsCmdArrForm op (Just fixity) [arg1, arg2] + +checkCmd l e = cmdFail l e + +checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName) +checkCmdLStmt = locMap checkCmdStmt + +checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName) +checkCmdStmt _ (LastStmt e r) = + checkCommand e >>= (\c -> return $ LastStmt c r) +checkCmdStmt _ (BindStmt pat e b f) = + checkCommand e >>= (\c -> return $ BindStmt pat c b f) +checkCmdStmt _ (BodyStmt e t g ty) = + checkCommand e >>= (\c -> return $ BodyStmt c t g ty) +checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds +checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do + ss <- mapM checkCmdLStmt stmts + return $ stmt { recS_stmts = ss } +checkCmdStmt l stmt = cmdStmtFail l stmt + +checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName)) +checkCmdMatchGroup (MatchGroup ms ty) = do + ms' <- mapM (locMap $ const convert) ms + return $ MatchGroup ms' ty + where convert (Match pat mty grhss) = do + grhss' <- checkCmdGRHSs grhss + return $ Match pat mty grhss' + +checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName)) +checkCmdGRHSs (GRHSs grhss binds) = do + grhss' <- mapM checkCmdGRHS grhss + return $ GRHSs grhss' binds + +checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName)) +checkCmdGRHS = locMap $ const convert + where + convert (GRHS stmts e) = do + c <- checkCommand e +-- cmdStmts <- mapM checkCmdLStmt stmts + return $ GRHS {- cmdStmts -} stmts c + + +cmdFail :: SrcSpan -> HsExpr RdrName -> P a +cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e) +cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a +cmdStmtFail loc e = parseErrorSDoc loc + (text "Parse error in command statement:" <+> ppr e) + --------------------------------------------------------------------------- -- Miscellaneous utilities diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 1b8d96df35..5d177d5016 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -654,7 +654,13 @@ The type constructor Any of kind forall k. k -> k has these properties: primitive type: - has a fixed unique, anyTyConKey, - lives in the global name cache - - built with TyCon.PrimTyCon + + * It is a *closed* type family, with no instances. This means that + if ty :: '(k1, k2) we add a given coercion + g :: ty ~ (Fst ty, Snd ty) + If Any was a *data* type, then we'd get inconsistency becuase 'ty' + could be (Any '(k1,k2)) and then we'd have an equality with Any on + one side and '(,) on the other * It is lifted, and hence represented by a pointer @@ -714,6 +720,17 @@ anyTyCon :: TyCon anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) +{- Can't do this yet without messing up kind proxies +anyTyCon :: TyCon +anyTyCon = mkSynTyCon anyTyConName kind [kKiVar] + syn_rhs + NoParentTyCon + where + kind = ForAllTy kKiVar (mkTyVarTy kKiVar) + syn_rhs = SynFamilyTyCon { synf_open = False, synf_injective = True } + -- NB Closed, injective +-} + anyTypeOfKind :: Kind -> Type anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind] \end{code} diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 75c49437c0..a0aea6a582 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -444,7 +444,7 @@ rnBind _ (L loc bind@(PatBind { pat_lhs = pat , bind_fvs = pat_fvs })) = setSrcSpan loc $ do { mod <- getModule - ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs grhss + ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss -- No scoped type variables for pattern bindings ; let all_fvs = pat_fvs `plusFV` rhs_fvs @@ -479,7 +479,7 @@ rnBind sig_fn (L loc bind@(FunBind { fun_id = name ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ -- bindSigTyVars tests for Opt_ScopedTyVars - rnMatchGroup (FunRhs plain_name is_infix) matches + rnMatchGroup (FunRhs plain_name is_infix) rnLExpr matches ; when is_infix $ checkPrecMatch plain_name matches' ; mod <- getModule @@ -612,7 +612,7 @@ rnMethodBind cls sig_fn -- We use the selector name as the binder (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ - mapFvRn (rnMatch (FunRhs plain_name is_infix)) matches + mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr) matches let new_group = MatchGroup new_matches placeHolderType when is_infix $ checkPrecMatch plain_name new_group @@ -758,16 +758,25 @@ okHsSig ctxt (L _ sig) %************************************************************************ \begin{code} -rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars) -rnMatchGroup ctxt (MatchGroup ms _) - = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms +rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> MatchGroup RdrName (Located (body RdrName)) + -> RnM (MatchGroup Name (Located (body Name)), FreeVars) +rnMatchGroup ctxt rnBody (MatchGroup ms _) + = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms ; return (MatchGroup new_ms placeHolderType, ms_fvs) } -rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) -rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) - -rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars) -rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) +rnMatch :: Outputable (body RdrName) => HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> LMatch RdrName (Located (body RdrName)) + -> RnM (LMatch Name (Located (body Name)), FreeVars) +rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) + +rnMatch' :: Outputable (body RdrName) => HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> Match RdrName (Located (body RdrName)) + -> RnM (Match Name (Located (body Name)), FreeVars) +rnMatch' ctxt rnBody match@(Match pats maybe_rhs_sig grhss) = do { -- Result type signatures are no longer supported case maybe_rhs_sig of Nothing -> return () @@ -776,11 +785,11 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) -- Now the main event -- note that there are no local ficity decls for matches ; rnPats ctxt pats $ \ pats' -> do - { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss + { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss ; return (Match pats' Nothing grhss', grhss_fvs) }} -resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc +resSigErr :: Outputable body => HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc resSigErr ctxt match ty = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty) , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches") @@ -795,21 +804,29 @@ resSigErr ctxt match ty %************************************************************************ \begin{code} -rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars) - -rnGRHSs ctxt (GRHSs grhss binds) +rnGRHSs :: HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> GRHSs RdrName (Located (body RdrName)) + -> RnM (GRHSs Name (Located (body Name)), FreeVars) +rnGRHSs ctxt rnBody (GRHSs grhss binds) = rnLocalBindsAndThen binds $ \ binds' -> do - (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt) grhss + (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss return (GRHSs grhss' binds', fvGRHSs) -rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars) -rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) - -rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars) -rnGRHS' ctxt (GRHS guards rhs) +rnGRHS :: HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> LGRHS RdrName (Located (body RdrName)) + -> RnM (LGRHS Name (Located (body Name)), FreeVars) +rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) + +rnGRHS' :: HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> GRHS RdrName (Located (body RdrName)) + -> RnM (GRHS Name (Located (body Name)), FreeVars) +rnGRHS' ctxt rnBody (GRHS guards rhs) = do { pattern_guards_allowed <- xoptM Opt_PatternGuards - ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ \ _ -> - rnLExpr rhs + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> + rnBody rhs ; unless (pattern_guards_allowed || is_standard_guard guards') (addWarn (nonStdGuardErr guards')) @@ -820,7 +837,7 @@ rnGRHS' ctxt (GRHS guards rhs) -- expression, rather than a list of qualifiers as in the -- Glasgow extension is_standard_guard [] = True - is_standard_guard [L _ (ExprStmt _ _ _ _)] = True + is_standard_guard [L _ (BodyStmt _ _ _ _)] = True is_standard_guard _ = False \end{code} @@ -861,7 +878,7 @@ bindsInHsBootFile mbinds = hang (ptext (sLit "Bindings in hs-boot files are not allowed")) 2 (ppr mbinds) -nonStdGuardErr :: [LStmtLR Name Name] -> SDoc +nonStdGuardErr :: Outputable body => [LStmtLR Name Name body] -> SDoc nonStdGuardErr guards = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)")) 4 (interpp'SP guards) diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index c232a89cd1..6385e1b52d 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -18,7 +18,7 @@ module RnEnv ( lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName, greRdrName, lookupSubBndrGREs, lookupConstructorFields, - lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, + lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, getLookupOccRn, addUsedRdrNames, @@ -1179,27 +1179,23 @@ lookupIfThenElse lookupSyntaxName :: Name -- The standard name -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name - = xoptM Opt_RebindableSyntax `thenM` \ rebindable_on -> - if not rebindable_on then normal_case - else - -- Get the similarly named thing from the local environment - lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> - return (HsVar usr_name, unitFV usr_name) - where - normal_case = return (HsVar std_name, emptyFVs) - -lookupSyntaxTable :: [Name] -- Standard names - -> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames -lookupSyntaxTable std_names - = xoptM Opt_RebindableSyntax `thenM` \ rebindable_on -> - if not rebindable_on then normal_case - else - -- Get the similarly named thing from the local environment - mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> - - return (std_names `zip` map HsVar usr_names, mkFVs usr_names) - where - normal_case = return (std_names `zip` map HsVar std_names, emptyFVs) + = do { rebindable_on <- xoptM Opt_RebindableSyntax + ; if not rebindable_on then + return (HsVar std_name, emptyFVs) + else + -- Get the similarly named thing from the local environment + do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) + ; return (HsVar usr_name, unitFV usr_name) } } + +lookupSyntaxNames :: [Name] -- Standard names + -> RnM ([HsExpr Name], FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxNames std_names + = do { rebindable_on <- xoptM Opt_RebindableSyntax + ; if not rebindable_on then + return (map HsVar std_names, emptyFVs) + else + do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names + ; return (map HsVar usr_names, mkFVs usr_names) } } \end{code} diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 78a64344f3..0d69d252f1 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -34,7 +34,7 @@ import HsSyn import TcRnMonad import TcEnv ( thRnBrack ) import RnEnv -import RnTypes +import RnTypes import RnPat import DynFlags import BasicTypes ( FixityDirection(..) ) @@ -221,16 +221,16 @@ rnExpr (HsTickPragma info expr) return (HsTickPragma info expr', fvs_expr) rnExpr (HsLam matches) - = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) -> + = rnMatchGroup LambdaExpr rnLExpr matches `thenM` \ (matches', fvMatch) -> return (HsLam matches', fvMatch) rnExpr (HsLamCase arg matches) - = rnMatchGroup CaseAlt matches `thenM` \ (matches', fvs_ms) -> + = rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (matches', fvs_ms) -> return (HsLamCase arg matches', fvs_ms) rnExpr (HsCase expr matches) - = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> - rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) -> + = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> + rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (new_matches, ms_fvs) -> return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) @@ -239,7 +239,7 @@ rnExpr (HsLet binds expr) return (HsLet binds' expr', fvExpr) rnExpr (HsDo do_or_lc stmts _) - = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs)) + = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } rnExpr (ExplicitList _ exps) @@ -285,7 +285,7 @@ rnExpr (HsIf _ p b1 b2) ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsMultiIf ty alts) - = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt) alts + = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts ; return (HsMultiIf ty alts', fvs) } rnExpr (HsType a) @@ -299,6 +299,9 @@ rnExpr (ArithSeq _ seq) rnExpr (PArrSeq _ seq) = rnArithSeq seq `thenM` \ (new_seq, fvs) -> return (PArrSeq noPostTcExpr new_seq, fvs) + +rnExpr HsHole + = return (HsHole, emptyFVs) \end{code} These three are pattern syntax appearing in expressions. @@ -306,7 +309,11 @@ Since all the symbols are reservedops we can simply reject them. We return a (bogus) EWildPat in each case. \begin{code} -rnExpr e@EWildPat = patSynErr e +rnExpr e@EWildPat = do { holes <- xoptM Opt_TypeHoles + ; if holes + then return (HsHole, emptyFVs) + else patSynErr e + } rnExpr e@(EAsPat {}) = patSynErr e rnExpr e@(EViewPat {}) = patSynErr e rnExpr e@(ELazyPat {}) = patSynErr e @@ -325,40 +332,21 @@ rnExpr (HsProc pat body) rnCmdTop body `thenM` \ (body',fvBody) -> return (HsProc pat' body', fvBody) -rnExpr (HsArrApp arrow arg _ ho rtl) - = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) -> - rnLExpr arg `thenM` \ (arg',fvArg) -> - return (HsArrApp arrow' arg' placeHolderType ho rtl, - fvArrow `plusFV` fvArg) - where - select_arrow_scope tc = case ho of - HsHigherOrderApp -> tc - HsFirstOrderApp -> escapeArrowScope tc - --- infix form -rnExpr (HsArrForm op (Just _) [arg1, arg2]) - = escapeArrowScope (rnLExpr op) - `thenM` \ (op',fv_op) -> - let L _ (HsVar op_name) = op' in - rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> - rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> - - -- Deal with fixity - - lookupFixityRn op_name `thenM` \ fixity -> - mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> - - return (final_e, - fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) - -rnExpr (HsArrForm op fixity cmds) - = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) -> - rnCmdArgs cmds `thenM` \ (cmds',fvCmds) -> - return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds) +-- Ideally, these would be done in parsing, but to keep parsing simple, we do it here. +rnExpr e@(HsArrApp {}) = arrowFail e +rnExpr e@(HsArrForm {}) = arrowFail e rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- HsWrap +arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +arrowFail e + = do { addErr (vcat [ ptext (sLit "Arrow command found where an expression was expected:") + , nest 2 (ppr e) ]) + -- Return a place-holder hole, so that we can carry on + -- to report other errors + ; return (HsHole, emptyFVs) } + ---------------------- -- See Note [Parsing sections] in Parser.y.pp rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) @@ -415,77 +403,90 @@ rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' where rnCmdTop' (HsCmdTop cmd _ _ _) - = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) -> - let - cmd_names = [arrAName, composeAName, firstAName] ++ - nameSetToList (methodNamesCmd (unLoc cmd')) - in + = do { (cmd', fvCmd) <- rnLCmd cmd + ; let cmd_names = [arrAName, composeAName, firstAName] ++ + nameSetToList (methodNamesCmd (unLoc cmd')) -- Generate the rebindable syntax for the monad - lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) -> + ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names - return (HsCmdTop cmd' [] placeHolderType cmd_names', - fvCmd `plusFV` cmd_fvs) + ; return (HsCmdTop cmd' [] placeHolderType (cmd_names `zip` cmd_names'), + fvCmd `plusFV` cmd_fvs) } ---------------------------------------------------- --- convert OpApp's in a command context to HsArrForm's +rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars) +rnLCmd = wrapLocFstM rnCmd -convertOpFormsLCmd :: LHsCmd id -> LHsCmd id -convertOpFormsLCmd = fmap convertOpFormsCmd +rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars) -convertOpFormsCmd :: HsCmd id -> HsCmd id +rnCmd (HsCmdArrApp arrow arg _ ho rtl) + = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) -> + rnLExpr arg `thenM` \ (arg',fvArg) -> + return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, + fvArrow `plusFV` fvArg) + where + select_arrow_scope tc = case ho of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc + -- See Note [Escaping the arrow scope] in TcRnTypes + -- Before renaming 'arrow', use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside 'arrow'. In the higher-order case (-<<), they are. -convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e -convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match) -convertOpFormsCmd (OpApp c1 op fixity c2) - = let - arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType [] - arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType [] - in - HsArrForm op (Just fixity) [arg1, arg2] +-- infix form +rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) + = escapeArrowScope (rnLExpr op) + `thenM` \ (op',fv_op) -> + let L _ (HsVar op_name) = op' in + rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> + rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> -convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c) + -- Deal with fixity -convertOpFormsCmd (HsCase exp matches) - = HsCase exp (convertOpFormsMatch matches) + lookupFixityRn op_name `thenM` \ fixity -> + mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> -convertOpFormsCmd (HsIf f exp c1 c2) - = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2) + return (final_e, + fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) -convertOpFormsCmd (HsLet binds cmd) - = HsLet binds (convertOpFormsLCmd cmd) +rnCmd (HsCmdArrForm op fixity cmds) + = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) -> + rnCmdArgs cmds `thenM` \ (cmds',fvCmds) -> + return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) -convertOpFormsCmd (HsDo DoExpr stmts ty) - = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty - -- Mark the HsDo as begin the body of an arrow command +rnCmd (HsCmdApp fun arg) + = rnLCmd fun `thenM` \ (fun',fvFun) -> + rnLExpr arg `thenM` \ (arg',fvArg) -> + return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) --- Anything else is unchanged. This includes HsArrForm (already done), --- things with no sub-commands, and illegal commands (which will be --- caught by the type checker) -convertOpFormsCmd c = c +rnCmd (HsCmdLam matches) + = rnMatchGroup LambdaExpr rnLCmd matches `thenM` \ (matches', fvMatch) -> + return (HsCmdLam matches', fvMatch) -convertOpFormsStmt :: StmtLR id id -> StmtLR id id -convertOpFormsStmt (BindStmt pat cmd _ _) - = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr -convertOpFormsStmt (ExprStmt cmd _ _ _) - = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType -convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts }) - = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts } -convertOpFormsStmt stmt = stmt +rnCmd (HsCmdPar e) + = do { (e', fvs_e) <- rnLCmd e + ; return (HsCmdPar e', fvs_e) } -convertOpFormsMatch :: MatchGroup id -> MatchGroup id -convertOpFormsMatch (MatchGroup ms ty) - = MatchGroup (map (fmap convert) ms) ty - where convert (Match pat mty grhss) - = Match pat mty (convertOpFormsGRHSs grhss) +rnCmd (HsCmdCase expr matches) + = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> + rnMatchGroup CaseAlt rnLCmd matches `thenM` \ (new_matches, ms_fvs) -> + return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) -convertOpFormsGRHSs :: GRHSs id -> GRHSs id -convertOpFormsGRHSs (GRHSs grhss binds) - = GRHSs (map convertOpFormsGRHS grhss) binds +rnCmd (HsCmdIf _ p b1 b2) + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLCmd b1 + ; (b2', fvB2) <- rnLCmd b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } + +rnCmd (HsCmdLet binds cmd) + = rnLocalBindsAndThen binds $ \ binds' -> + rnLCmd cmd `thenM` \ (cmd',fvExpr) -> + return (HsCmdLet binds' cmd', fvExpr) + +rnCmd (HsCmdDo stmts _) + = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsCmdDo stmts' placeHolderType, fvs ) } -convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id) -convertOpFormsGRHS = fmap convert - where - convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd) --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are @@ -497,32 +498,32 @@ methodNamesLCmd = methodNamesCmd . unLoc methodNamesCmd :: HsCmd Name -> CmdNeeds -methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl) +methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl) = emptyFVs -methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl) +methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl) = unitFV appAName -methodNamesCmd (HsArrForm {}) = emptyFVs +methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsPar c) = methodNamesLCmd c +methodNamesCmd (HsCmdPar c) = methodNamesLCmd c -methodNamesCmd (HsIf _ _ c1 c2) +methodNamesCmd (HsCmdIf _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsLet _ c) = methodNamesLCmd c -methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts -methodNamesCmd (HsApp c _) = methodNamesLCmd c -methodNamesCmd (HsLam match) = methodNamesMatch match +methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts +methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c +methodNamesCmd (HsCmdLam match) = methodNamesMatch match -methodNamesCmd (HsCase _ matches) +methodNamesCmd (HsCmdCase _ matches) = methodNamesMatch matches `addOneFV` choiceAName -methodNamesCmd _ = emptyFVs +--methodNamesCmd _ = emptyFVs -- Other forms can't occur in commands, but it's not convenient -- to error here so we just do what's convenient. -- The type checker will complain later --------------------------------------------------- -methodNamesMatch :: MatchGroup Name -> FreeVars +methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars methodNamesMatch (MatchGroup ms _) = plusFVs (map do_one ms) where @@ -530,25 +531,25 @@ methodNamesMatch (MatchGroup ms _) ------------------------------------------------- -- gaw 2004 -methodNamesGRHSs :: GRHSs Name -> FreeVars +methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss) ------------------------------------------------- -methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds +methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs --------------------------------------------------- -methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars +methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) --------------------------------------------------- -methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars +methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc -methodNamesStmt :: StmtLR Name Name -> FreeVars +methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd -methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd +methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt {}) = emptyFVs @@ -650,59 +651,62 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" %************************************************************************ \begin{code} -rnStmts :: HsStmtContext Name -> [LStmt RdrName] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) +rnStmts :: Outputable (body RdrName) => HsStmtContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [LStmt RdrName (Located (body RdrName))] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) -- Variables bound by the Stmts, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmts ctxt [] thing_inside +rnStmts ctxt _ [] thing_inside = do { checkEmptyStmts ctxt ; (thing, fvs) <- thing_inside [] ; return (([], thing), fvs) } -rnStmts MDoExpr stmts thing_inside -- Deal with mdo +rnStmts MDoExpr rnBody stmts thing_inside -- Deal with mdo = -- Behave like do { rec { ...all but last... }; last } do { ((stmts1, (stmts2, thing)), fvs) - <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ -> + <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> do { last_stmt' <- checkLastStmt MDoExpr last_stmt - ; rnStmt MDoExpr last_stmt' thing_inside } + ; rnStmt MDoExpr rnBody last_stmt' thing_inside } ; return (((stmts1 ++ stmts2), thing), fvs) } where Just (all_but_last, last_stmt) = snocView stmts -rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside +rnStmts ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside | null lstmts = setSrcSpan loc $ do { lstmt' <- checkLastStmt ctxt lstmt - ; rnStmt ctxt lstmt' thing_inside } + ; rnStmt ctxt rnBody lstmt' thing_inside } | otherwise = do { ((stmts1, (stmts2, thing)), fvs) <- setSrcSpan loc $ do { checkStmt ctxt lstmt - ; rnStmt ctxt lstmt $ \ bndrs1 -> - rnStmts ctxt lstmts $ \ bndrs2 -> + ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> + rnStmts ctxt rnBody lstmts $ \ bndrs2 -> thing_inside (bndrs1 ++ bndrs2) } ; return (((stmts1 ++ stmts2), thing), fvs) } ---------------------- -rnStmt :: HsStmtContext Name - -> LStmt RdrName +rnStmt :: Outputable (body RdrName) => HsStmtContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> LStmt RdrName (Located (body RdrName)) -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) + -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmt ctxt (L loc (LastStmt expr _)) thing_inside - = do { (expr', fv_expr) <- rnLExpr expr +rnStmt ctxt rnBody (L loc (LastStmt body _)) thing_inside + = do { (body', fv_expr) <- rnBody body ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName ; (thing, fvs3) <- thing_inside [] - ; return (([L loc (LastStmt expr' ret_op)], thing), + ; return (([L loc (LastStmt body' ret_op)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } -rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside - = do { (expr', fv_expr) <- rnLExpr expr +rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside + = do { (body', fv_expr) <- rnBody body ; (then_op, fvs1) <- lookupStmtName ctxt thenMName ; (guard_op, fvs2) <- if isListCompExpr ctxt then lookupStmtName ctxt guardMName @@ -711,27 +715,27 @@ rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] -- Here "gd" is a guard ; (thing, fvs3) <- thing_inside [] - ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing), + ; return (([L loc (BodyStmt body' then_op guard_op placeHolderType)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } -rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside - = do { (expr', fv_expr) <- rnLExpr expr +rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside + = do { (body', fv_expr) <- rnBody body -- The binders do not scope over the expression ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName ; (fail_op, fvs2) <- lookupStmtName ctxt failMName ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat') - ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing), + ; return (([L loc (BindStmt pat' body' bind_op fail_op)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt _ (L loc (LetStmt binds)) thing_inside +rnStmt _ _ (L loc (LetStmt binds)) thing_inside = do { rnLocalBindsAndThen binds $ \binds' -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return (([L loc (LetStmt binds')], thing), fvs) } } -rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside +rnStmt ctxt rnBody (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside = do { -- Step1: Bring all the binders of the mdo into scope -- (Remember that this also removes the binders from the @@ -742,7 +746,7 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside -- for which it's the fwd refs within the bind itself -- (This set may not be empty, because we're in a recursive -- context.) - ; rnRecStmtsAndThen rec_stmts $ \ segs -> do + ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) emptyNameSet segs @@ -774,7 +778,7 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } -rnStmt ctxt (L loc (ParStmt segs _ _)) thing_inside +rnStmt ctxt _ (L loc (ParStmt segs _ _)) thing_inside = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName ; (return_op, fvs3) <- lookupStmtName ctxt returnMName @@ -782,7 +786,7 @@ rnStmt ctxt (L loc (ParStmt segs _ _)) thing_inside ; return ( ([L loc (ParStmt segs' mzip_op bind_op)], thing) , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } -rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form +rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form , trS_using = using })) thing_inside = do { -- Rename the 'using' expression in the context before the transform is begun (using', fvs1) <- rnLExpr using @@ -790,7 +794,7 @@ rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs -> + <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by ; (thing, fvs_thing) <- thing_inside bndrs ; let fvs = fvs_by `plusFV` fvs_thing @@ -838,7 +842,7 @@ rnParallelStmts ctxt return_op segs thing_inside rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) - <- rnStmts ctxt stmts $ \ bndrs -> + <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> setLocalRdrEnv env $ do { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs ; let used_bndrs = filter (`elemNameSet` fvs) bndrs @@ -864,7 +868,7 @@ lookupStmtName ctxt n DoExpr -> rebindable MDoExpr -> rebindable MonadComp -> rebindable - GhciStmt -> rebindable -- I suppose? + GhciStmtCtxt -> rebindable -- I suppose? ParStmtCtxt c -> lookupStmtName c n -- Look inside to TransStmtCtxt c -> lookupStmtName c n -- the parent context @@ -908,12 +912,14 @@ type Segment stmts = (Defs, -- wrapper that does both the left- and right-hand sides -rnRecStmtsAndThen :: [LStmt RdrName] +rnRecStmtsAndThen :: Outputable (body RdrName) => + (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [LStmt RdrName (Located (body RdrName))] -- assumes that the FreeVars returned includes -- the FreeVars of the Segments - -> ([Segment (LStmt Name)] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnRecStmtsAndThen s cont + -> ([Segment (LStmt Name (Located (body Name)))] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnRecStmtsAndThen rnBody s cont = do { -- (A) Make the mini fixity env for all of the stmts fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) @@ -928,13 +934,13 @@ rnRecStmtsAndThen s cont addLocalFixities fix_env bound_names $ do -- (C) do the right-hand-sides and thing-inside - { segs <- rn_rec_stmts bound_names new_lhs_and_fv + { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv ; (res, fvs) <- cont segs ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses) ; return (res, fvs) }} -- get all the fixity decls in any Let stmt -collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName] +collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) -> @@ -945,24 +951,24 @@ collectRecStmtsFixities l = -- left-hand sides -rn_rec_stmt_lhs :: MiniFixityEnv - -> LStmt RdrName +rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv + -> LStmt RdrName body -- rename LHS, and return its FVs -- Warning: we will only need the FreeVars below in the case of a BindStmt, -- so we don't bother to compute it accurately in the other cases - -> RnM [(LStmtLR Name RdrName, FreeVars)] + -> RnM [(LStmtLR Name RdrName body, FreeVars)] -rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c)) - = return [(L loc (ExprStmt expr a b c), emptyFVs)] +rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) + = return [(L loc (BodyStmt body a b c), emptyFVs)] -rn_rec_stmt_lhs _ (L loc (LastStmt expr a)) - = return [(L loc (LastStmt expr a), emptyFVs)] +rn_rec_stmt_lhs _ (L loc (LastStmt body a)) + = return [(L loc (LastStmt body a), emptyFVs)] -rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) +rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b)) = do -- should the ctxt be MDo instead? (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat - return [(L loc (BindStmt pat' expr a b), + return [(L loc (BindStmt pat' body a b), fv_pat)] rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _))) @@ -988,9 +994,9 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds)) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" -rn_rec_stmts_lhs :: MiniFixityEnv - -> [LStmt RdrName] - -> RnM [(LStmtLR Name RdrName, FreeVars)] +rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv + -> [LStmt RdrName body] + -> RnM [(LStmtLR Name RdrName body, FreeVars)] rn_rec_stmts_lhs fix_env stmts = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts ; let boundNames = collectLStmtsBinders (map fst ls) @@ -1003,24 +1009,27 @@ rn_rec_stmts_lhs fix_env stmts -- right-hand-sides -rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)] +rn_rec_stmt :: (Outputable (body RdrName)) => + (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [Name] -> LStmtLR Name RdrName (Located (body RdrName)) + -> FreeVars -> RnM [Segment (LStmt Name (Located (body Name)))] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt -rn_rec_stmt _ (L loc (LastStmt expr _)) _ - = do { (expr', fv_expr) <- rnLExpr expr +rn_rec_stmt rnBody _ (L loc (LastStmt body _)) _ + = do { (body', fv_expr) <- rnBody body ; (ret_op, fvs1) <- lookupSyntaxName returnMName ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, - L loc (LastStmt expr' ret_op))] } + L loc (LastStmt body' ret_op))] } -rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _ - = rnLExpr expr `thenM` \ (expr', fvs) -> +rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _)) _ + = rnBody body `thenM` \ (body', fvs) -> lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))] + L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] -rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat - = rnLExpr expr `thenM` \ (expr', fv_expr) -> +rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _)) fv_pat + = rnBody body `thenM` \ (body', fv_expr) -> lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) -> lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) -> let @@ -1028,12 +1037,12 @@ rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 in return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt pat' expr' bind_op fail_op))] + L loc (BindStmt pat' body' bind_op fail_op))] -rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _ +rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _))) _ = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) -rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do +rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do (binds', du_binds) <- -- fixities and unused are handled above in rnRecStmtsAndThen rnLocalValBindsRHS (mkNameSet all_bndrs) binds' @@ -1041,21 +1050,26 @@ rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do emptyNameSet, L loc (LetStmt (HsValBinds binds')))] -- no RecStmt case becuase they get flattened above when doing the LHSes -rn_rec_stmt _ stmt@(L _ (RecStmt {})) _ +rn_rec_stmt _ _ stmt@(L _ (RecStmt {})) _ = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) -rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo +rn_rec_stmt _ _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) -rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo +rn_rec_stmt _ _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _ +rn_rec_stmt _ _ (L _ (LetStmt EmptyLocalBinds)) _ = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" -rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)] -rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s -> - return (concat segs_s) +rn_rec_stmts :: Outputable (body RdrName) => + (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [Name] + -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] + -> RnM [Segment (LStmt Name (Located (body Name)))] +rn_rec_stmts rnBody bndrs stmts = + mapM (uncurry (rn_rec_stmt rnBody bndrs)) stmts `thenM` \ segs_s -> + return (concat segs_s) --------------------------------------------- addFwdRefs :: [Segment a] -> [Segment a] @@ -1114,7 +1128,7 @@ addFwdRefs pairs -- See http://hackage.haskell.org/trac/ghc/ticket/4148 for -- the discussion leading to this design choice. -glomSegments :: HsStmtContext Name -> [Segment (LStmt Name)] -> [Segment [LStmt Name]] +glomSegments :: HsStmtContext Name -> [Segment (LStmt Name body)] -> [Segment [LStmt Name body]] glomSegments _ [] = [] glomSegments ctxt ((defs,uses,fwds,stmt) : segs) @@ -1145,10 +1159,10 @@ glomSegments ctxt ((defs,uses,fwds,stmt) : segs) ---------------------------------------------------- -segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in - -> [Segment [LStmt Name]] - -> FreeVars -- Free vars used 'later' - -> ([LStmt Name], FreeVars) +segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in + -> [Segment [LStmt Name body]] + -> FreeVars -- Free vars used 'later' + -> ([LStmt Name body], FreeVars) segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later @@ -1218,9 +1232,9 @@ emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'grou emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt ---------------------- -checkLastStmt :: HsStmtContext Name - -> LStmt RdrName - -> RnM (LStmt RdrName) +checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name + -> LStmt RdrName (Located (body RdrName)) + -> RnM (LStmt RdrName (Located (body RdrName))) checkLastStmt ctxt lstmt@(L loc stmt) = case ctxt of ListComp -> check_comp @@ -1231,9 +1245,9 @@ checkLastStmt ctxt lstmt@(L loc stmt) MDoExpr -> check_do _ -> check_other where - check_do -- Expect ExprStmt, and change it to LastStmt + check_do -- Expect BodyStmt, and change it to LastStmt = case stmt of - ExprStmt e _ _ _ -> return (L loc (mkLastStmt e)) + BodyStmt e _ _ _ -> return (L loc (mkLastStmt e)) LastStmt {} -> return lstmt -- "Deriving" clauses may generate a -- LastStmt directly (unlike the parser) _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } @@ -1250,7 +1264,7 @@ checkLastStmt ctxt lstmt@(L loc stmt) -- Checking when a particular Stmt is ok checkStmt :: HsStmtContext Name - -> LStmt RdrName + -> LStmt RdrName (Located (body RdrName)) -> RnM () checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags @@ -1261,10 +1275,10 @@ checkStmt ctxt (L _ stmt) msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement") , ptext (sLit "in") <+> pprAStmtContext ctxt ] -pprStmtCat :: Stmt a -> SDoc +pprStmtCat :: Stmt a body -> SDoc pprStmtCat (TransStmt {}) = ptext (sLit "transform") pprStmtCat (LastStmt {}) = ptext (sLit "return expression") -pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion") +pprStmtCat (BodyStmt {}) = ptext (sLit "body") pprStmtCat (BindStmt {}) = ptext (sLit "binding") pprStmtCat (LetStmt {}) = ptext (sLit "let") pprStmtCat (RecStmt {}) = ptext (sLit "rec") @@ -1277,7 +1291,7 @@ notOK = Just empty okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt :: DynFlags -> HsStmtContext Name - -> Stmt RdrName -> Maybe SDoc + -> Stmt RdrName (Located (body RdrName)) -> Maybe SDoc -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to an generic error message @@ -1288,17 +1302,17 @@ okStmt dflags ctxt stmt DoExpr -> okDoStmt dflags ctxt stmt MDoExpr -> okDoStmt dflags ctxt stmt ArrowExpr -> okDoStmt dflags ctxt stmt - GhciStmt -> okDoStmt dflags ctxt stmt + GhciStmtCtxt -> okDoStmt dflags ctxt stmt ListComp -> okCompStmt dflags ctxt stmt MonadComp -> okCompStmt dflags ctxt stmt PArrComp -> okPArrStmt dflags ctxt stmt TransStmtCtxt ctxt -> okStmt dflags ctxt stmt ------------- -okPatGuardStmt :: Stmt RdrName -> Maybe SDoc +okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Maybe SDoc okPatGuardStmt stmt = case stmt of - ExprStmt {} -> isOK + BodyStmt {} -> isOK BindStmt {} -> isOK LetStmt {} -> isOK _ -> notOK @@ -1318,7 +1332,7 @@ okDoStmt dflags ctxt stmt | otherwise -> Just (ptext (sLit "Use -XRecursiveDo")) BindStmt {} -> isOK LetStmt {} -> isOK - ExprStmt {} -> isOK + BodyStmt {} -> isOK _ -> notOK ---------------- @@ -1326,7 +1340,7 @@ okCompStmt dflags _ stmt = case stmt of BindStmt {} -> isOK LetStmt {} -> isOK - ExprStmt {} -> isOK + BodyStmt {} -> isOK ParStmt {} | Opt_ParallelListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) @@ -1341,7 +1355,7 @@ okPArrStmt dflags _ stmt = case stmt of BindStmt {} -> isOK LetStmt {} -> isOK - ExprStmt {} -> isOK + BodyStmt {} -> isOK ParStmt {} | Opt_ParallelListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot index 70d891dcbf..0a00a9e2bc 100644 --- a/compiler/rename/RnExpr.lhs-boot +++ b/compiler/rename/RnExpr.lhs-boot @@ -1,17 +1,21 @@ \begin{code} module RnExpr where import HsSyn -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) +import Name ( Name ) +import NameSet ( FreeVars ) +import RdrName ( RdrName ) import TcRnTypes +import SrcLoc ( Located ) +import Outputable ( Outputable ) rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) -rnStmts :: --forall thing. - HsStmtContext Name -> [LStmt RdrName] +rnStmts :: --forall thing body. + Outputable (body RdrName) => HsStmtContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [LStmt RdrName (Located (body RdrName))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) + -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) \end{code} diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 57f75fb50d..c3b40fe0f2 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -158,8 +158,8 @@ matchNameMaker ctxt = LamMk report_unused -- Do not report unused names in interactive contexts -- i.e. when you type 'x <- e' at the GHCi prompt report_unused = case ctxt of - StmtCtxt GhciStmt -> False - _ -> True + StmtCtxt GhciStmtCtxt -> False + _ -> True rnHsSigCps :: HsWithBndrs (LHsType RdrName) -> CpsRn (HsWithBndrs (LHsType Name)) rnHsSigCps sig diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index d9809239e2..f8bbc3d68e 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -654,15 +654,15 @@ mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged -> RnM (HsCmd Name) -- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _)) +mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _)) op2 fix2 a2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (HsArrForm op2 (Just fix2) [a1, a2]) + return (HsCmdArrForm op2 (Just fix2) [a1, a2]) | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 - return (HsArrForm op1 (Just fix1) + return (HsCmdArrForm op1 (Just fix1) [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) -- TODO: locs are wrong where @@ -670,7 +670,7 @@ mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _ -- Default case mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = return (HsArrForm op (Just fix) [arg1, arg2]) + = return (HsCmdArrForm op (Just fix) [arg1, arg2]) -------------------------------------- @@ -699,7 +699,7 @@ not_op_pat (ConPatIn _ (InfixCon _ _)) = False not_op_pat _ = True -------------------------------------- -checkPrecMatch :: Name -> MatchGroup Name -> RnM () +checkPrecMatch :: Name -> MatchGroup Name body -> RnM () -- Check precedence of a function binding written infix -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index eed579eed7..678136d439 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -477,7 +477,7 @@ mkStgAltType bndr alts = case repType (idType bndr) of _is_poly_alt_tycon tc = isFunTyCon tc || isPrimTyCon tc -- "Any" is lifted but primitive - || isFamilyTyCon tc -- Type family; e.g. arising from strict + || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict -- function application where argument has a -- type-family type diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index b6370b5c92..45ef02657e 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -26,7 +26,6 @@ import Name import Module import Outputable import UniqFM -import VarSet import FastString import Util import Maybes @@ -177,7 +176,9 @@ tcLookupFamInst tycon tys | otherwise = do { instEnv <- tcGetFamInstEnvs ; let mb_match = lookupFamInstEnv instEnv tycon tys - ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ ppr mb_match $$ ppr instEnv) +-- ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ +-- pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ +-- ppr mb_match $$ ppr instEnv) ; case mb_match of [] -> return Nothing ((fam_inst, rep_tys):_) diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 2de781578d..dac8fd1367 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -25,15 +25,12 @@ module Inst ( tcSyntaxName, -- Simple functions over evidence variables - hasEqualities, unitImplication, + hasEqualities, tyVarsOfWC, tyVarsOfBag, - tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication, - tyVarsOfCt, tyVarsOfCts, tyVarsOfCDict, tyVarsOfCDicts, + tyVarsOfCt, tyVarsOfCts, - tidyEvVar, tidyCt, tidyGivenLoc, - - substEvVar, substImplication, substCt + tidyEvVar, tidyCt, tidySkolemInfo ) where #include "HsVersions.h" @@ -86,7 +83,7 @@ emitWanted :: CtOrigin -> TcPredType -> TcM EvVar emitWanted origin pred = do { loc <- getCtLoc origin ; ev <- newWantedEvVar pred - ; emitFlat (mkNonCanonical (Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev })) + ; emitFlat (mkNonCanonical loc (CtWanted { ctev_pred = pred, ctev_evar = ev })) ; return ev } newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) @@ -337,9 +334,8 @@ tcSyntaxName :: CtOrigin -> TcType -- Type to instantiate it at -> (Name, HsExpr Name) -- (Standard name, user name) -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression) --- *** NOW USED ONLY FOR CmdTop (sigh) *** --- NB: tcSyntaxName calls tcExpr, and hence can do unification. --- So we do not call it from lookupInst, which is called from tcSimplify +-- USED ONLY FOR CmdTop (sigh) *** +-- See Note [CmdSyntaxTable] in HsExpr tcSyntaxName orig ty (std_nm, HsVar user_nm) | std_nm == user_nm @@ -366,14 +362,14 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv -> TcRn (TidyEnv, SDoc) -syntaxNameCtxt name orig ty tidy_env = do - inst_loc <- getCtLoc orig - let - msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+> - ptext (sLit "(needed by a syntactic construct)"), - nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)), - nest 2 (pprArisingAt inst_loc)] - return (tidy_env, msg) +syntaxNameCtxt name orig ty tidy_env + = do { inst_loc <- getCtLoc orig + ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name) + <+> ptext (sLit "(needed by a syntactic construct)") + , nest 2 (ptext (sLit "has the required type:") + <+> ppr (tidyType tidy_env ty)) + , nest 2 (pprArisingAt inst_loc) ] + ; return (tidy_env, msg) } \end{code} @@ -515,11 +511,6 @@ addClsInstsErr herald ispecs %************************************************************************ \begin{code} -unitImplication :: Implication -> Bag Implication -unitImplication implic - | isEmptyWC (ic_wanted implic) = emptyBag - | otherwise = unitBag implic - hasEqualities :: [EvVar] -> Bool -- Has a bunch of canonical constraints (all givens) got any equalities in it? hasEqualities givens = any (has_eq . evVarPred) givens @@ -534,37 +525,30 @@ hasEqualities givens = any (has_eq . evVarPred) givens ---------------- 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_ty = ty }) = tyVarsOfType ty -tyVarsOfCt (CNonCanonical { cc_ev = fl }) = tyVarsOfType (ctEvPred fl) - -tyVarsOfCDict :: Ct -> TcTyVarSet -tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys -tyVarsOfCDict _ct = emptyVarSet - -tyVarsOfCDicts :: Cts -> TcTyVarSet -tyVarsOfCDicts = foldrBag (unionVarSet . tyVarsOfCDict) emptyVarSet +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 tyVarsOfWC :: WantedConstraints -> TyVarSet +-- Only called on *zonked* things, hence no need to worry about flatten-skolems tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) = tyVarsOfCts flat `unionVarSet` - tyVarsOfBag tyVarsOfImplication implic `unionVarSet` + tyVarsOfBag tyVarsOfImplic implic `unionVarSet` tyVarsOfCts insol -tyVarsOfImplication :: Implication -> TyVarSet -tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted }) - = tyVarsOfWC wanted `delVarSetList` skols - -tyVarsOfEvVar :: EvVar -> TyVarSet -tyVarsOfEvVar ev = tyVarsOfType $ evVarPred ev - -tyVarsOfEvVars :: [EvVar] -> TyVarSet -tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet +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 }) + = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens)) + `delVarSetList` skols `delVarSetList` fsks tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet @@ -575,95 +559,45 @@ tidyCt :: TidyEnv -> Ct -> Ct -- Used only in error reporting -- Also converts it to non-canonical tidyCt env ct - = CNonCanonical { cc_ev = tidy_flavor env (cc_ev ct) - , cc_depth = cc_depth ct } + = case ct of + CHoleCan { cc_ev = ev } + -> ct { cc_ev = tidy_ev env ev } + _ -> CNonCanonical { cc_ev = tidy_ev env (cc_ev ct) + , cc_loc = cc_loc ct } where - tidy_flavor :: TidyEnv -> CtEvidence -> CtEvidence + tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence -- NB: we do not tidy the ctev_evtm/var field because we don't -- show it in error messages - tidy_flavor env ctev@(Given { ctev_gloc = gloc, ctev_pred = pred }) - = ctev { ctev_gloc = tidyGivenLoc env gloc - , ctev_pred = tidyType env pred } - tidy_flavor env ctev@(Wanted { ctev_pred = pred }) + tidy_ev env ctev@(CtGiven { ctev_pred = pred }) = ctev { ctev_pred = tidyType env pred } - tidy_flavor env ctev@(Derived { ctev_pred = pred }) + tidy_ev env ctev@(CtWanted { ctev_pred = pred }) + = ctev { ctev_pred = tidyType env pred } + tidy_ev env ctev@(CtDerived { ctev_pred = pred }) = ctev { ctev_pred = tidyType env pred } tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = setVarType var (tidyType env (varType var)) -tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc -tidyGivenLoc env (CtLoc skol span ctxt) - = CtLoc (tidySkolemInfo env skol) span ctxt - -tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo -tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty) -tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) -tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) - = UnifyForAllSkol (map tidy_tv skol_tvs) (tidyType env ty) - where - tidy_tv tv = case getTyVar_maybe ty' of - Just tv' -> tv' - Nothing -> pprPanic "ticySkolemInfo" (ppr tv <+> ppr ty') - where - ty' = tidyTyVarOcc env tv -tidySkolemInfo _ info = info - ----------------- Substitution ------------------------- --- This is used only in TcSimpify, for substituations that are *also* --- reflected in the unification variables. So we don't substitute --- in the evidence. - -substCt :: TvSubst -> Ct -> Ct --- Conservatively converts it to non-canonical: --- Postcondition: if the constraint does not get rewritten -substCt subst ct - | pty <- ctPred ct - , sty <- substTy subst pty - = if sty `eqType` pty then - ct { cc_ev = substFlavor subst (cc_ev ct) } - else - CNonCanonical { cc_ev = substFlavor subst (cc_ev ct) - , cc_depth = cc_depth ct } - -substWC :: TvSubst -> WantedConstraints -> WantedConstraints -substWC subst (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) - = WC { wc_flat = mapBag (substCt subst) flat - , wc_impl = mapBag (substImplication subst) implic - , wc_insol = mapBag (substCt subst) insol } - -substImplication :: TvSubst -> Implication -> Implication -substImplication subst implic@(Implic { ic_skols = tvs - , ic_given = given - , ic_wanted = wanted - , ic_loc = loc }) - = implic { ic_skols = tvs' - , ic_given = map (substEvVar subst1) given - , ic_wanted = substWC subst1 wanted - , ic_loc = substGivenLoc subst1 loc } +tidySkolemInfo :: TidyEnv -> SkolemInfo -> (TidyEnv, SkolemInfo) +tidySkolemInfo env (SigSkol cx ty) + = (env', SigSkol cx ty') where - (subst1, tvs') = mapAccumL substTyVarBndr subst tvs - -substEvVar :: TvSubst -> EvVar -> EvVar -substEvVar subst var = setVarType var (substTy subst (varType var)) - -substFlavor :: TvSubst -> CtEvidence -> CtEvidence -substFlavor subst ctev@(Given { ctev_gloc = gloc, ctev_pred = pred }) - = ctev { ctev_gloc = substGivenLoc subst gloc - , ctev_pred = substTy subst pred } + (env', ty') = tidyOpenType env ty -substFlavor subst ctev@(Wanted { ctev_pred = pred }) - = ctev { ctev_pred = substTy subst pred } - -substFlavor subst ctev@(Derived { ctev_pred = pty }) - = ctev { ctev_pred = substTy subst pty } +tidySkolemInfo env (InferSkol ids) + = (env', InferSkol ids') + where + (env', ids') = mapAccumL do_one env ids + do_one env (name, ty) = (env', (name, ty')) + where + (env', ty') = tidyOpenType env ty -substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc -substGivenLoc subst (CtLoc skol span ctxt) - = CtLoc (substSkolemInfo subst skol) span ctxt +tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) + = (env1, UnifyForAllSkol skol_tvs' ty') + where + env1 = tidyFreeTyVars env (tyVarsOfType ty `delVarSetList` skol_tvs) + (env2, skol_tvs') = tidyTyVarBndrs env1 skol_tvs + ty' = tidyType env2 ty -substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo -substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty) -substSkolemInfo subst (InferSkol ids) = InferSkol (mapSnd (substTy subst) ids) -substSkolemInfo _ info = info +tidySkolemInfo env info = (env, info) \end{code} diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index e15b2adc6e..f851e75206 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -18,6 +18,7 @@ import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId ) import HsSyn import TcMatches +-- import TcSimplify( solveWantedsTcM ) import TcType import TcMType import TcBinds @@ -98,42 +99,42 @@ tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty ---------------------------------------- -tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId) +tcCmd :: CmdEnv -> LHsCmd Name -> (CmdStack, TcTauType) -> TcM (LHsCmd TcId) -- The main recursive function -tcCmd env (L loc expr) res_ty +tcCmd env (L loc cmd) res_ty = setSrcSpan loc $ do - { expr' <- tc_cmd env expr res_ty - ; return (L loc expr') } + { cmd' <- tc_cmd env cmd res_ty + ; return (L loc cmd') } -tc_cmd :: CmdEnv -> HsExpr Name -> (CmdStack, TcTauType) -> TcM (HsExpr TcId) -tc_cmd env (HsPar cmd) res_ty +tc_cmd :: CmdEnv -> HsCmd Name -> (CmdStack, TcTauType) -> TcM (HsCmd TcId) +tc_cmd env (HsCmdPar cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty - ; return (HsPar cmd') } + ; return (HsCmdPar cmd') } -tc_cmd env (HsLet binds (L body_loc body)) res_ty +tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ setSrcSpan body_loc $ tc_cmd env body res_ty - ; return (HsLet binds' (L body_loc body')) } + ; return (HsCmdLet binds' (L body_loc body')) } -tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty) +tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do (scrut', scrut_ty) <- tcInferRho scrut matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty - return (HsCase scrut' matches') + return (HsCmdCase scrut' matches') where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body } mc_body body res_ty' = tcCmd env body (stk, res_ty') -tc_cmd env (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' +tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcMonoExpr pred boolTy ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty - ; return (HsIf Nothing pred' b1' b2') + ; return (HsCmdIf Nothing pred' b1' b2') } -tc_cmd env (HsIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if +tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if = do { pred_ty <- newFlexiTyVarTy openTypeKind -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not @@ -147,36 +148,38 @@ tc_cmd env (HsIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if ; pred' <- tcMonoExpr pred pred_ty ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty - ; return (HsIf (Just fun') pred' b1' b2') + ; return (HsCmdIf (Just fun') pred' b1' b2') } ------------------------------------------- -- Arrow application -- (f -< a) or (f -<< a) -tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newFlexiTyVarTy openTypeKind ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) + -- ToDo: There should be no need for the escapeArrowScope stuff + -- See Note [Escaping the arrow scope] in TcRnTypes ; arg' <- tcMonoExpr arg arg_ty - ; return (HsArrApp fun' arg' fun_ty ho_app lr) } + ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } where - -- Before type-checking f, use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside f. In the higher-order case (-<<), they are. + -- Before type-checking f, use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside f. In the higher-order case (-<<), they are. select_arrow_scope tc = case ho_app of - HsHigherOrderApp -> tc - HsFirstOrderApp -> escapeArrowScope tc + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc ------------------------------------------- -- Command application -tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newFlexiTyVarTy openTypeKind @@ -184,12 +187,12 @@ tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) ; arg' <- tcMonoExpr arg arg_ty - ; return (HsApp fun' arg') } + ; return (HsCmdApp fun' arg') } ------------------------------------------- -- Lambda -tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] _)) +tc_cmd env cmd@(HsCmdLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] _)) (cmd_stk, res_ty) = addErrCtxt (pprMatchInCtxt match_ctxt match) $ @@ -203,7 +206,7 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig tc_grhss grhss res_ty ; let match' = L mtch_loc (Match pats' Nothing grhss') - ; return (HsLam (MatchGroup [match'] res_ty)) + ; return (HsCmdLam (MatchGroup [match'] res_ty)) } where @@ -225,10 +228,10 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig ------------------------------------------- -- Do notation -tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdDo stmts _) (cmd_stk, res_ty) = do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd) - ; stmts' <- tcStmts do_or_lc (tcArrDoStmt env) stmts res_ty - ; return (HsDo do_or_lc stmts' res_ty) } + ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty + ; return (HsCmdDo stmts' res_ty) } where @@ -242,7 +245,7 @@ tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) -- ---------------------------------------------- -- G |-a (| e c |) : [t1 .. tn] t -tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..] ; (_, [w_tv]) <- tcInstSkolTyVars [alphaTyVar] @@ -256,16 +259,34 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) ; let e_ty = mkFunTys [mkAppTys b [tup,s] | (_,_,b,tup,s) <- cmds_w_tys] e_res_ty + -- ToDo: SLPJ: something is badly wrong here. + -- The escapeArrowScope pops the Untouchables.. but that + -- risks screwing up the skolem-escape check + -- Moreover, arrowfail001 fails with an ASSERT failure + -- because a variable gets the wrong level -- Check expr - ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $ - escapeArrowScope (tcMonoExpr expr e_ty) + ; (inner_binds, expr') + <- checkConstraints ArrowSkol [w_tv] [] $ + escapeArrowScope (tcMonoExpr expr e_ty) + +{- + ; ((inner_binds, expr'), lie) + <- captureConstraints $ + checkConstraints ArrowSkol [w_tv] [] $ + tcMonoExpr expr e_ty + -- No need for escapeArrowScope in the + -- type checker. + -- Note [Escaping the arrow scope] in TcRnTypes + ; (lie, outer_binds) <- solveWantedsTcM lie + ; emitConstraints lie +-} -- OK, now we are in a position to unscramble -- the s1..sm and check each cmd ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys - ; let wrap = WpTyLam w_tv <.> mkWpLet inst_binds - ; return (HsArrForm (mkLHsWrap wrap expr') fixity cmds') } + ; let wrap = WpTyLam w_tv <.> mkWpLet inner_binds + ; return (HsCmdArrForm (mkLHsWrap wrap expr') fixity cmds') } where -- Make the types -- b, ((e,s1) .. sm), s @@ -331,16 +352,16 @@ tc_cmd _ cmd _ -- (a) RecStmts, and -- (b) no rebindable syntax -tcArrDoStmt :: CmdEnv -> TcStmtChecker +tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside = do { rhs' <- tcCmd env rhs ([], res_ty) ; thing <- thing_inside (panic "tcArrDoStmt") ; return (LastStmt rhs' noSyntaxExpr, thing) } -tcArrDoStmt env _ (ExprStmt rhs _ _ _) res_ty thing_inside +tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside = do { (rhs', elt_ty) <- tc_arr_rhs env rhs ; thing <- thing_inside res_ty - ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } + ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', pat_ty) <- tc_arr_rhs env rhs @@ -381,7 +402,7 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names tcArrDoStmt _ _ stmt _ _ = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) -tc_arr_rhs :: CmdEnv -> LHsExpr Name -> TcM (LHsExpr TcId, TcType) +tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType) tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcCmd env rhs ([], ty) ; return (rhs', ty) } @@ -411,15 +432,15 @@ arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind %************************************************************************ \begin{code} -cmdCtxt :: HsExpr Name -> SDoc +cmdCtxt :: HsCmd Name -> SDoc cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd -nonEmptyCmdStkErr :: HsExpr Name -> SDoc +nonEmptyCmdStkErr :: HsCmd Name -> SDoc nonEmptyCmdStkErr cmd = hang (ptext (sLit "Non-empty command stack at command:")) 2 (ppr cmd) -kappaUnderflow :: HsExpr Name -> SDoc +kappaUnderflow :: HsCmd Name -> SDoc kappaUnderflow cmd = hang (ptext (sLit "Command stack underflow at command:")) 2 (ppr cmd) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index f9c58ccd99..cd010ef03c 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -6,7 +6,7 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, - tcHsBootSigs, tcPolyBinds, tcPolyCheck, + tcHsBootSigs, tcPolyCheck, PragFun, tcSpecPrags, tcVectDecls, mkPragFun, TcSigInfo(..), TcSigFun, instTcTySig, instTcTySigFromId, @@ -274,7 +274,8 @@ tcValBinds top_lvl binds sigs thing_inside -- Extend the envt right away with all -- the Ids declared with type signatures - ; (binds', thing) <- tcExtendIdEnv poly_ids $ + -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack + ; (binds', thing) <- tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $ tcBindGroups top_lvl sig_fn prag_fn binds thing_inside @@ -336,7 +337,8 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing) go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc - ; (binds2, ids2, thing) <- tcExtendLetEnv closed ids1 $ go sccs + ; (binds2, ids2, thing) <- tcExtendLetEnv closed ids1 $ + go sccs ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) } go [] = do { thing <- thing_inside; return (emptyBag, [], thing) } @@ -397,20 +399,15 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list { traceTc "------------------------------------------------" empty ; traceTc "Bindings for {" (ppr binder_names) - --- -- Instantiate the polytypes of any binders that have signatures --- -- (as determined by sig_fn), returning a TcSigInfo for each --- ; tc_sig_fn <- tcInstSigs sig_fn binder_names - ; dflags <- getDynFlags ; type_env <- getLclTypeEnv ; let plan = decideGeneralisationPlan dflags type_env binder_names bind_list sig_fn ; traceTc "Generalisation plan" (ppr plan) ; result@(tc_binds, poly_ids, _) <- case plan of - NoGen -> tcPolyNoGen sig_fn prag_fn rec_tc bind_list - InferGen mn cl -> tcPolyInfer mn cl sig_fn prag_fn rec_tc bind_list - CheckGen sig -> tcPolyCheck sig prag_fn rec_tc bind_list + NoGen -> tcPolyNoGen top_lvl rec_tc prag_fn sig_fn bind_list + InferGen mn cl -> tcPolyInfer top_lvl rec_tc prag_fn sig_fn mn cl bind_list + CheckGen sig -> tcPolyCheck top_lvl rec_tc prag_fn sig bind_list -- Check whether strict bindings are ok -- These must be non-recursive etc, and are not generalised @@ -429,17 +426,18 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list -- span that includes them all ------------------ -tcPolyNoGen - :: TcSigFun -> PragFun +tcPolyNoGen -- No generalisation whatsoever + :: TopLevelFlag -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures + -> PragFun -> TcSigFun -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) --- No generalisation whatsoever -tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list - = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn) - rec_tc bind_list +tcPolyNoGen top_lvl rec_tc prag_fn tc_sig_fn bind_list + = do { (binds', mono_infos) <- tcMonoBinds top_lvl rec_tc tc_sig_fn + (LetGblBndr prag_fn) + bind_list ; mono_ids' <- mapM tc_mono_info mono_infos ; return (binds', mono_ids', NotTopLevel) } where @@ -455,17 +453,19 @@ tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list -- So we can safely ignore _specs ------------------ -tcPolyCheck :: TcSigInfo -> PragFun +tcPolyCheck :: TopLevelFlag -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures + -> PragFun -> TcSigInfo -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) -- There is just one binding, -- it binds a single variable, -- it has a signature, -tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped +tcPolyCheck top_lvl rec_tc prag_fn + sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped , sig_theta = theta, sig_tau = tau, sig_loc = loc }) - prag_fn rec_tc bind_list + bind_list = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau) prag_sigs = prag_fn (idName poly_id) @@ -474,7 +474,7 @@ tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped <- setSrcSpan loc $ checkConstraints skol_info tvs ev_vars $ tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $ - tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list + tcMonoBinds top_lvl rec_tc (\_ -> Just sig) LetLclBndr bind_list ; spec_prags <- tcSpecPrags poly_id prag_sigs ; poly_id <- addInlinePrags poly_id prag_sigs @@ -494,22 +494,22 @@ tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped ------------------ tcPolyInfer - :: Bool -- True <=> apply the monomorphism restriction - -> Bool -- True <=> free vars have closed types - -> TcSigFun -> PragFun + :: TopLevelFlag -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures + -> PragFun -> TcSigFun + -> Bool -- True <=> apply the monomorphism restriction + -> Bool -- True <=> free vars have closed types -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) -tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list - = do { (((binds', mono_infos), untch), wanted) +tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn mono closed bind_list + = do { ((binds', mono_infos), wanted) <- captureConstraints $ - captureUntouchables $ - tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list + tcMonoBinds top_lvl rec_tc tc_sig_fn LetLclBndr bind_list ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos] ; (qtvs, givens, mr_bites, ev_binds) <- - simplifyInfer closed mono name_taus (untch,wanted) + simplifyInfer closed mono name_taus wanted ; theta <- zonkTcThetaType (map evVarPred givens) ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos @@ -525,10 +525,8 @@ tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list ; traceTc "Binding:" (ppr final_closed $$ ppr (poly_ids `zip` map idType poly_ids)) - ; return (unitBag abs_bind, poly_ids, final_closed) + ; return (unitBag abs_bind, poly_ids, final_closed) } -- poly_ids are guaranteed zonked by mkExport - } - -------------- mkExport :: PragFun @@ -938,14 +936,15 @@ should not typecheck because will not typecheck. \begin{code} -tcMonoBinds :: TcSigFun -> LetBndrSpec +tcMonoBinds :: TopLevelFlag -> RecFlag -- Whether the binding is recursive for typechecking purposes -- i.e. the binders are mentioned in their RHSs, and -- we are not rescued by a type signature + -> TcSigFun -> LetBndrSpec -> [LHsBind Name] -> TcM (LHsBinds TcId, [MonoBindInfo]) -tcMonoBinds sig_fn no_gen is_rec +tcMonoBinds top_lvl is_rec sig_fn no_gen [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches, bind_fvs = fvs })] -- Single function binding, @@ -957,15 +956,17 @@ tcMonoBinds sig_fn no_gen is_rec -- e.g. f = \(x::forall a. a->a) -> <body> -- We want to infer a higher-rank type for f setSrcSpan b_loc $ - do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches) - + do { rhs_ty <- newFlexiTyVarTy openTypeKind ; mono_id <- newNoSigLetBndr no_gen name rhs_ty + ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id top_lvl] $ + tcMatchesFun name inf matches rhs_ty + ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', bind_fvs = fvs, fun_co_fn = co_fn, fun_tick = Nothing })), [(name, Nothing, mono_id)]) } -tcMonoBinds sig_fn no_gen _ binds +tcMonoBinds top_lvl _ sig_fn no_gen binds = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds -- Bring the monomorphic Ids, into scope for the RHSs @@ -974,10 +975,10 @@ tcMonoBinds sig_fn no_gen _ binds -- A monomorphic binding for each term variable that lacks -- a type sig. (Ones with a sig are already in scope.) - ; binds' <- tcExtendIdEnv2 rhs_id_env $ do - traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) - | (n,id) <- rhs_id_env] - mapM (wrapLocM tcRhs) tc_binds + ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) + | (n,id) <- rhs_id_env] + ; binds' <- tcExtendIdEnv2 rhs_id_env $ + mapM (wrapLocM (tcRhs top_lvl)) tc_binds ; return (listToBag binds', mono_info) } ------------------------ @@ -997,8 +998,8 @@ tcMonoBinds sig_fn no_gen _ binds -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't data TcMonoBind -- Half completed; LHS done, RHS not done - = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name) - | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType + = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name (LHsExpr Name)) + | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) -- Type signature (if any), and @@ -1033,13 +1034,14 @@ tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) -- AbsBind, VarBind impossible ------------------- -tcRhs :: TcMonoBind -> TcM (HsBind TcId) +tcRhs :: TopLevelFlag -> TcMonoBind -> TcM (HsBind TcId) -- When we are doing pattern bindings, or multiple function bindings at a time -- we *don't* bring any scoped type variables into scope -- Wny not? They are not completely rigid. -- That's why we have the special case for a single FunBind in tcMonoBinds -tcRhs (TcFunBind (_,_,mono_id) loc inf matches) - = do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) +tcRhs top_lvl (TcFunBind (_,_,mono_id) loc inf matches) + = tcExtendIdBndrs [TcIdBndr mono_id top_lvl] $ + do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf matches (idType mono_id) ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf @@ -1047,8 +1049,9 @@ tcRhs (TcFunBind (_,_,mono_id) loc inf matches) , fun_co_fn = co_fn , bind_fvs = placeHolderNames, fun_tick = Nothing }) } -tcRhs (TcPatBind _ pat' grhss pat_ty) - = do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) +tcRhs top_lvl (TcPatBind infos pat' grhss pat_ty) + = tcExtendIdBndrs [ TcIdBndr mono_id top_lvl | (_,_,mono_id) <- infos ] $ + do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ tcGRHSsPat grhss pat_ty ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty @@ -1391,7 +1394,7 @@ strictBindErr flavour unlifted binds \begin{code} -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: OutputableBndr id => LPat id -> GRHSs Name -> SDoc +patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc patMonoBindsCtxt pat grhss = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss) \end{code} diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index d38345844d..33c62dcc15 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -7,8 +7,7 @@ -- for details module TcCanonical( - canonicalize, flatten, flattenMany, occurCheckExpand, - FlattenMode (..), + canonicalize, occurCheckExpand, emitWorkNC, StopOrContinue (..) ) where @@ -28,19 +27,14 @@ import Outputable import Control.Monad ( when ) import MonadUtils import Control.Applicative ( (<|>) ) +import TysWiredIn ( eqTyCon ) -import TrieMap import VarSet import TcSMonad import FastString import Util - - -import TysWiredIn ( eqTyCon ) - -import Data.Maybe ( isJust, fromMaybe ) --- import Data.List ( zip4 ) +import Maybes( catMaybes ) \end{code} @@ -171,48 +165,46 @@ EvBinds, so we are again good. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ canonicalize :: Ct -> TcS StopOrContinue -canonicalize ct@(CNonCanonical { cc_ev = fl, cc_depth = d }) +canonicalize ct@(CNonCanonical { cc_ev = ev, cc_loc = d }) = do { traceTcS "canonicalize (non-canonical)" (ppr ct) ; {-# SCC "canEvVar" #-} - canEvVar d fl } + canEvNC d ev } -canonicalize (CDictCan { cc_depth = d - , cc_ev = fl +canonicalize (CDictCan { cc_loc = d + , cc_ev = ev , cc_class = cls , cc_tyargs = xis }) = {-# SCC "canClass" #-} - canClass d fl cls xis -- Do not add any superclasses -canonicalize (CTyEqCan { cc_depth = d - , cc_ev = fl + canClass d ev cls xis -- Do not add any superclasses +canonicalize (CTyEqCan { cc_loc = d + , cc_ev = ev , cc_tyvar = tv , cc_rhs = xi }) - = {-# SCC "canEqLeafTyVarLeftRec" #-} - canEqLeafTyVarLeftRec d fl tv xi + = {-# SCC "canEqLeafTyVarEq" #-} + canEqLeafTyVarEq d ev tv xi -canonicalize (CFunEqCan { cc_depth = d - , cc_ev = fl +canonicalize (CFunEqCan { cc_loc = d + , cc_ev = ev , cc_fun = fn , cc_tyargs = xis1 , cc_rhs = xi2 }) - = {-# SCC "canEqLeafFunEqLeftRec" #-} - canEqLeafFunEqLeftRec d fl (fn,xis1) xi2 + = {-# SCC "canEqLeafFunEq" #-} + canEqLeafFunEq d ev fn xis1 xi2 -canonicalize (CIrredEvCan { cc_ev = fl - , cc_depth = d - , cc_ty = xi }) - = canIrred d fl xi +canonicalize (CIrredEvCan { cc_ev = ev + , cc_loc = d }) + = canIrred d ev +canonicalize (CHoleCan { cc_ev = ev, cc_loc = d }) + = canHole d ev - -canEvVar :: SubGoalDepth - -> CtEvidence - -> TcS StopOrContinue +canEvNC :: CtLoc -> CtEvidence -> TcS StopOrContinue -- Called only for non-canonical EvVars -canEvVar d fl - = case classifyPredType (ctEvPred fl) of - ClassPred cls tys -> canClassNC d fl cls tys - EqPred ty1 ty2 -> canEqNC d fl ty1 ty2 - IrredPred ev_ty -> canIrred d fl ev_ty - TuplePred tys -> canTuple d fl tys +canEvNC d ev + = case classifyPredType (ctEvPred ev) of + ClassPred cls tys -> canClassNC d ev cls tys + EqPred ty1 ty2 -> canEqNC d ev ty1 ty2 + TuplePred tys -> canTuple d ev tys + IrredPred {} -> canIrred d ev \end{code} @@ -223,20 +215,15 @@ canEvVar d fl %************************************************************************ \begin{code} -canTuple :: SubGoalDepth -- Depth - -> CtEvidence -> [PredType] -> TcS StopOrContinue -canTuple d fl tys +canTuple :: CtLoc -> CtEvidence -> [PredType] -> TcS StopOrContinue +canTuple d ev tys = do { traceTcS "can_pred" (text "TuplePred!") ; let xcomp = EvTupleMk xdecomp x = zipWith (\_ i -> EvTupleSel x i) tys [0..] - ; ctevs <- xCtFlavor fl tys (XEvTerm xcomp xdecomp) - ; mapM_ add_to_work ctevs - ; return Stop } - where - add_to_work fl = addToWork $ canEvVar d fl + ; ctevs <- xCtFlavor ev tys (XEvTerm xcomp xdecomp) + ; canEvVarsCreated d ctevs } \end{code} - %************************************************************************ %* * %* Class Canonicalization @@ -245,7 +232,7 @@ canTuple d fl tys \begin{code} canClass, canClassNC - :: SubGoalDepth -- Depth + :: CtLoc -> CtEvidence -> Class -> [Type] -> TcS StopOrContinue -- Precondition: EvVar is class evidence @@ -255,32 +242,27 @@ canClass, canClassNC -- for already-canonical class constraints (but which might have -- been subsituted or somthing), and hence do not need superclasses -canClassNC d fl cls tys - = canClass d fl cls tys +canClassNC d ev cls tys + = canClass d ev cls tys `andWhenContinue` emitSuperclasses -canClass d fl cls tys - = do { -- sctx <- getTcSContext - ; (xis, cos) <- flattenMany d FMFullFlatten fl tys +canClass d ev cls tys + = do { (xis, cos) <- flattenMany d FMFullFlatten (ctEvFlavour ev) tys ; let co = mkTcTyConAppCo (classTyCon cls) cos xi = mkClassPred cls xis - - ; mb <- rewriteCtFlavor fl xi co - + ; mb <- rewriteCtFlavor ev xi co ; case mb of - Just new_fl -> - let (ClassPred cls xis_for_dict) = classifyPredType (ctEvPred new_fl) - in continueWith $ - CDictCan { cc_ev = new_fl - , cc_tyargs = xis_for_dict, cc_class = cls, cc_depth = d } - Nothing -> return Stop } + Nothing -> return Stop + Just new_ev -> continueWith $ + CDictCan { cc_ev = new_ev, cc_loc = d + , cc_tyargs = xis, cc_class = cls } } emitSuperclasses :: Ct -> TcS StopOrContinue -emitSuperclasses ct@(CDictCan { cc_depth = d, cc_ev = fl +emitSuperclasses ct@(CDictCan { cc_loc = d, 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. - = do { newSCWorkFromFlavored d fl cls xis_new + = do { newSCWorkFromFlavored d ev cls xis_new -- Arguably we should "seq" the coercions if they are derived, -- as we do below for emit_kind_constraint, to allow errors in -- superclasses to be executed if deferred to runtime! @@ -352,8 +334,7 @@ By adding superclasses definitely only once, during canonicalisation, this situa happen. \begin{code} - -newSCWorkFromFlavored :: SubGoalDepth -- Depth +newSCWorkFromFlavored :: CtLoc -- Depth -> CtEvidence -> Class -> [Xi] -> TcS () -- Returns superclasses, see Note [Adding superclasses] newSCWorkFromFlavored d flavor cls xis @@ -367,9 +348,7 @@ newSCWorkFromFlavored d flavor cls xis xev = XEvTerm { ev_comp = panic "Can't compose for given!" , ev_decomp = xev_decomp } ; ctevs <- xCtFlavor flavor sc_theta xev - - ; traceTcS "newSCWork/Given" $ ppr "ctevs =" <+> ppr ctevs - ; mapM_ emit_non_can ctevs } + ; emitWorkNC d ctevs } | isEmptyVarSet (tyVarsOfTypes xis) = return () -- Wanteds with no variables yield no deriveds. @@ -379,13 +358,8 @@ newSCWorkFromFlavored d flavor cls xis = do { let sc_rec_theta = transSuperClasses cls xis impr_theta = filter is_improvement_pty sc_rec_theta ; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta - ; mapM_ emit_der impr_theta } - - where emit_der pty = newDerived (ctev_wloc flavor) pty >>= mb_emit - mb_emit Nothing = return () - mb_emit (Just ctev) = emit_non_can ctev - emit_non_can ctev = updWorkListTcS $ - extendWorkListCt (CNonCanonical ctev d) + ; mb_der_evs <- mapM newDerived impr_theta + ; emitWorkNC d (catMaybes mb_der_evs) } is_improvement_pty :: PredType -> Bool -- Either it's an equality, or has some functional dependency @@ -407,25 +381,35 @@ is_improvement_pty ty = go (classifyPredType ty) \begin{code} -canIrred :: SubGoalDepth -- Depth - -> CtEvidence -> TcType -> TcS StopOrContinue +canIrred :: CtLoc -> CtEvidence -> TcS StopOrContinue -- Precondition: ty not a tuple and no other evidence form -canIrred d fl ty - = do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) - ; (xi,co) <- flatten d FMFullFlatten fl ty -- co :: xi ~ ty +canIrred d ev + = do { let ty = ctEvPred ev + ; traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) + ; (xi,co) <- flatten d FMFullFlatten (ctEvFlavour ev) ty -- co :: xi ~ ty ; let no_flattening = xi `eqType` ty - -- In this particular case it is not safe to - -- say 'isTcReflCo' because the new constraint may - -- be reducible! - ; mb <- rewriteCtFlavor fl xi co + -- We can't use isTcReflCo, because even if the coercion is + -- Refl, the output type might have had a substitution + -- applied to it. For example 'a' might now be 'C b' + + ; if no_flattening then + continueWith $ + CIrredEvCan { cc_ev = ev, cc_loc = d } + else do + { mb <- rewriteCtFlavor ev xi co + ; case mb of + Just new_ev -> canEvNC d new_ev -- Re-classify and try again + Nothing -> return Stop } } -- Found a cached copy + +canHole :: CtLoc -> CtEvidence -> TcS StopOrContinue +canHole d ev + = do { let ty = ctEvPred ev + ; (xi,co) <- flatten d FMFullFlatten (ctEvFlavour ev) ty -- co :: xi ~ ty + ; mb <- rewriteCtFlavor ev xi co ; case mb of - Just new_fl - | no_flattening - -> continueWith $ - CIrredEvCan { cc_ev = new_fl, cc_ty = xi, cc_depth = d } - | otherwise - -> canEvVar d new_fl - Nothing -> return Stop } + Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_loc = d}) + Nothing -> return () -- Found a cached copy; won't happen + ; return Stop } \end{code} %************************************************************************ @@ -476,16 +460,16 @@ unexpanded synonym. \begin{code} -data FlattenMode = FMSubstOnly - | FMFullFlatten +data FlattenMode = FMSubstOnly | FMFullFlatten -- Flatten a bunch of types all at once. -flattenMany :: SubGoalDepth -- Depth - -> FlattenMode - -> CtEvidence -> [Type] -> TcS ([Xi], [TcCoercion]) +flattenMany :: CtLoc -> FlattenMode + -> CtFlavour -> [Type] -> TcS ([Xi], [TcCoercion]) -- Coercions :: Xi ~ Type -- Returns True iff (no flattening happened) --- NB: The EvVar inside the flavor is unused, we merely want Given/Solved/Derived/Wanted info +-- 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 d f ctxt tys = -- pprTrace "flattenMany" empty $ go tys @@ -497,36 +481,35 @@ flattenMany d f ctxt tys -- 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. -flatten :: SubGoalDepth -- Depth - -> FlattenMode - -> CtEvidence -> TcType -> TcS (Xi, TcCoercion) +flatten :: CtLoc -> FlattenMode + -> CtFlavour -> TcType -> TcS (Xi, TcCoercion) -- Postcondition: Coercion :: Xi ~ TcType -flatten d f ctxt ty +flatten loc f ctxt ty | Just ty' <- tcView ty - = do { (xi, co) <- flatten d f ctxt ty' + = do { (xi, co) <- flatten loc f ctxt ty' ; if eqType xi ty then return (ty,co) else return (xi,co) } -- Small tweak for better error messages flatten _ _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi) -flatten d f ctxt (TyVarTy tv) - = flattenTyVar d f ctxt tv +flatten loc f ctxt (TyVarTy tv) + = flattenTyVar loc f ctxt tv -flatten d f ctxt (AppTy ty1 ty2) - = do { (xi1,co1) <- flatten d f ctxt ty1 - ; (xi2,co2) <- flatten d f ctxt ty2 +flatten loc f ctxt (AppTy ty1 ty2) + = do { (xi1,co1) <- flatten loc f ctxt ty1 + ; (xi2,co2) <- flatten loc f ctxt ty2 ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) } -flatten d f ctxt (FunTy ty1 ty2) - = do { (xi1,co1) <- flatten d f ctxt ty1 - ; (xi2,co2) <- flatten d f ctxt ty2 +flatten loc f ctxt (FunTy ty1 ty2) + = do { (xi1,co1) <- flatten loc f ctxt ty1 + ; (xi2,co2) <- flatten loc f ctxt ty2 ; return (mkFunTy xi1 xi2, mkTcFunCo co1 co2) } -flatten d f fl (TyConApp tc tys) +flatten loc f ctxt (TyConApp tc tys) -- For a normal type constructor or data family application, we just -- recursively flatten the arguments. | not (isSynFamilyTyCon tc) - = do { (xis,cos) <- flattenMany d f fl tys + = do { (xis,cos) <- flattenMany loc f ctxt tys ; return (mkTyConApp tc xis, mkTcTyConAppCo tc cos) } -- Otherwise, it's a type function application, and we have to @@ -534,23 +517,24 @@ flatten d f fl (TyConApp tc tys) -- between the application and a newly generated flattening skolem variable. | otherwise = ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated - do { (xis, cos) <- flattenMany d f fl tys - ; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis + do { (xis, cos) <- flattenMany loc 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 fam_ty = mkTyConApp tc xi_args - ; (ret_co, rhs_xi, ct) <- + ; (ret_co, rhs_xi) <- case f of FMSubstOnly -> - return (mkTcReflCo fam_ty, fam_ty, []) + return (mkTcReflCo fam_ty, fam_ty) FMFullFlatten -> - do { flat_cache <- getFlatCache - ; case lookupTM fam_ty flat_cache of - Just ct - | let ctev = cc_ev ct - , ctev `canRewrite` fl + do { mb_ct <- lookupFlatEqn fam_ty + ; case mb_ct of + Just (ctev, rhs_ty) + | let flav = ctEvFlavour ctev + , flav `canRewrite` ctxt -> -- 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 @@ -559,49 +543,23 @@ flatten d f fl (TyConApp tc tys) -- 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 { traceTcS "flatten/flat-cache hit" $ ppr ct - ; let rhs_xi = cc_rhs ct - ; (flat_rhs_xi,co) <- flatten (cc_depth ct) f ctev rhs_xi + do { traceTcS "flatten/flat-cache hit" $ ppr ctev + ; (rhs_xi,co) <- flatten loc f flav rhs_ty ; let final_co = evTermCoercion (ctEvTerm ctev) `mkTcTransCo` mkTcSymCo co - ; return (final_co, flat_rhs_xi,[]) } + ; return (final_co, rhs_xi) } - _ | isGiven fl -- Given: make new flatten skolem - -> do { traceTcS "flatten/flat-cache miss" $ empty - ; rhs_xi_var <- newFlattenSkolemTy fam_ty - ; let co = mkTcReflCo fam_ty - new_fl = Given { ctev_gloc = ctev_gloc fl - , ctev_pred = mkTcEqPred fam_ty rhs_xi_var - , ctev_evtm = EvCoercion co } - ct = CFunEqCan { cc_ev = new_fl - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_xi_var - , cc_depth = d } - -- Update the flat cache - ; updFlatCache ct - ; return (co, rhs_xi_var, [ct]) } - | otherwise -- Wanted or Derived: make new unification variable - -> do { traceTcS "flatten/flat-cache miss" $ empty - ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty) - ; let pred = mkTcEqPred fam_ty rhs_xi_var - wloc = ctev_wloc fl - ; mw <- newWantedEvVar wloc pred - ; case mw of - Fresh ctev -> - do { let ct = CFunEqCan { cc_ev = ctev - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_xi_var - , cc_depth = d } - -- Update the flat cache: just an optimisation! - ; updFlatCache ct - ; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var, [ct]) } - Cached {} -> panic "flatten TyConApp, var must be fresh!" } + _ -> do { traceTcS "flatten/flat-cache miss" $ ppr fam_ty + ; (ctev, rhs_xi) <- newFlattenSkolem ctxt fam_ty + ; let ct = CFunEqCan { cc_ev = ctev + , cc_fun = tc + , cc_tyargs = xi_args + , cc_rhs = rhs_xi + , cc_loc = loc } + ; updWorkListTcS $ extendWorkListFunEq ct + ; return (evTermCoercion (ctEvTerm ctev), rhs_xi) } } -- Emit the flat constraints - ; updWorkListTcS $ appendWorkListEqs ct - ; let (cos_args, cos_rest) = splitAt (tyConArity tc) cos ; 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 tc cos_args) $ @@ -609,45 +567,89 @@ flatten d f fl (TyConApp tc tys) ) } -flatten d _f ctxt ty@(ForAllTy {}) +flatten loc _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 d FMSubstOnly ctxt rho + ; (rho', co) <- flatten loc 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 under a forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Under a forall, we + (a) MUST apply the inert subsitution + (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} -flattenTyVar :: SubGoalDepth - -> FlattenMode - -> CtEvidence -> TcTyVar -> TcS (Xi, TcCoercion) +flattenTyVar, flattenFinalTyVar + :: CtLoc -> FlattenMode + -> CtFlavour -> TcTyVar -> TcS (Xi, TcCoercion) -- "Flattening" a type variable means to apply the substitution to it -flattenTyVar d f ctxt tv - = do { ieqs <- getInertEqs - ; let mco = tv_eq_subst (fst ieqs) tv -- co : v ~ ty - ; case mco of -- Done, but make sure the kind is zonked +-- 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. +flattenTyVar loc f ctxt tv + | not (isTcTyVar tv) -- Happens when flatten under a (forall a. ty) + = flattenFinalTyVar loc f ctxt tv -- So ty contains referneces to the non-TcTyVar a + | otherwise + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of { + Just ty -> flatten loc f ctxt ty ; Nothing -> - do { let knd = tyVarKind tv - ; (new_knd,_kind_co) <- flatten d f ctxt knd - ; let ty = mkTyVarTy (setVarType tv new_knd) - ; return (ty, mkTcReflCo ty) } - -- NB recursive call. - -- Why? Because inert subst. non-idempotent, Note [Detailed InertCans Invariants] - -- In fact, because of flavors, it couldn't possibly be idempotent, - -- this is explained in Note [Non-idempotent inert substitution] + + -- Try in ty_binds + do { ty_binds <- getTcSTyBindsMap + ; case lookupVarEnv ty_binds tv of { + Just (_tv,ty) -> flatten loc f ctxt ty ; + -- NB: ty_binds coercions are all ReflCo, + -- so no need to transitively compose co' with another coercion, + -- unlike in 'flatten_from_inerts' + Nothing -> + + -- Try in the inert equalities + do { ieqs <- getInertEqs + ; let mco = tv_eq_subst ieqs tv -- co : v ~ ty + ; case mco of { Just (co,ty) -> - do { (ty_final,co') <- flatten d f ctxt ty - ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } } - where + do { (ty_final,co') <- flatten loc f ctxt ty + ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } ; + -- NB recursive call. + -- Why? Because inert subst. non-idempotent, Note [Detailed InertCans Invariants] + -- In fact, because of flavors, it couldn't possibly be idempotent, + -- this is explained in Note [Non-idempotent inert substitution] + + Nothing -> flattenFinalTyVar loc f ctxt tv + } } } } } } + where tv_eq_subst subst tv | Just ct <- lookupVarEnv subst tv , let ctev = cc_ev ct - , ctev `canRewrite` ctxt + , ctEvFlavour ctev `canRewrite` ctxt = Just (evTermCoercion (ctEvTerm ctev), cc_rhs ct) -- NB: even if ct is Derived we are not going to -- touch the actual coercion so we are fine. | otherwise = Nothing + +flattenFinalTyVar loc f ctxt tv + = -- Done, but make sure the kind is zonked + do { let knd = tyVarKind tv + ; (new_knd,_kind_co) <- flatten loc f ctxt knd + ; let ty = mkTyVarTy (setVarType tv new_knd) + ; return (ty, mkTcReflCo ty) } \end{code} Note [Non-idempotent inert substitution] @@ -678,16 +680,6 @@ so that we can make sure that the inert substitution /is/ fully applied. Insufficient (non-recursive) rewriting was the reason for #5668. -\begin{code} - ------------------ -addToWork :: TcS StopOrContinue -> TcS () -addToWork tcs_action = tcs_action >>= stop_or_emit - where stop_or_emit Stop = return () - stop_or_emit (ContinueWith ct) = updWorkListTcS $ - extendWorkListCt ct -\end{code} - %************************************************************************ %* * @@ -696,185 +688,195 @@ addToWork tcs_action = tcs_action >>= stop_or_emit %************************************************************************ \begin{code} -canEqEvVarsCreated :: SubGoalDepth - -> [CtEvidence] -> TcS StopOrContinue -canEqEvVarsCreated _d [] = return Stop -canEqEvVarsCreated d (quad:quads) - = mapM_ (addToWork . do_quad) quads >> do_quad quad - -- Add all but one to the work list - -- and return the first (if any) for futher processing - where do_quad fl = let EqPred ty1 ty2 = classifyPredType $ ctEvPred fl - in canEqNC d fl ty1 ty2 - -- Note the "NC": these are fresh equalities so we must be - -- careful to add their kind constraints +canEvVarsCreated :: CtLoc -> [CtEvidence] -> TcS StopOrContinue +canEvVarsCreated _loc [] = return Stop + -- Add all but one to the work list + -- and return the first (if any) for futher processing +canEvVarsCreated loc (ev : evs) + = do { emitWorkNC loc evs; canEvNC loc ev } + -- Note the "NC": these are fresh goals, not necessarily canonical + +emitWorkNC :: CtLoc -> [CtEvidence] -> TcS () +emitWorkNC loc evs + | null evs = return () + | otherwise = updWorkListTcS (extendWorkListCts (map mk_nc evs)) + where + mk_nc ev = CNonCanonical { cc_ev = ev, cc_loc = loc } ------------------------- -canEqNC, canEq - :: SubGoalDepth - -> CtEvidence - -> Type -> Type -> TcS StopOrContinue +canEqNC, canEq :: CtLoc -> CtEvidence -> Type -> Type -> TcS StopOrContinue -canEqNC d fl ty1 ty2 - = canEq d fl ty1 ty2 +canEqNC loc ev ty1 ty2 + = canEq loc ev ty1 ty2 `andWhenContinue` emitKindConstraint -canEq _d fl ty1 ty2 +canEq _loc ev ty1 ty2 | eqType ty1 ty2 -- Dealing with equality here avoids -- later spurious occurs checks for a~a - = if isWanted fl then - setEvBind (ctev_evar fl) (EvCoercion (mkTcReflCo ty1)) >> return Stop + = if isWanted ev then + setEvBind (ctev_evar ev) (EvCoercion (mkTcReflCo ty1)) >> return Stop else return Stop -- If one side is a variable, orient and flatten, -- WITHOUT expanding type synonyms, so that we tend to -- substitute a ~ Age rather than a ~ Int when @type Age = Int@ -canEq d fl ty1@(TyVarTy {}) ty2 - = canEqLeaf d fl ty1 ty2 -canEq d fl ty1 ty2@(TyVarTy {}) - = canEqLeaf d fl ty1 ty2 +canEq loc ev ty1@(TyVarTy {}) ty2 + = canEqLeaf loc ev ty1 ty2 +canEq loc ev ty1 ty2@(TyVarTy {}) + = canEqLeaf loc ev ty1 ty2 -- See Note [Naked given applications] -canEq d fl ty1 ty2 - | Just ty1' <- tcView ty1 = canEq d fl ty1' ty2 - | Just ty2' <- tcView ty2 = canEq d fl ty1 ty2' +canEq loc ev ty1 ty2 + | Just ty1' <- tcView ty1 = canEq loc ev ty1' ty2 + | Just ty2' <- tcView ty2 = canEq loc ev ty1 ty2' -canEq d fl ty1@(TyConApp fn tys) ty2 +canEq loc ev ty1@(TyConApp fn tys) ty2 | isSynFamilyTyCon fn, length tys == tyConArity fn - = canEqLeaf d fl ty1 ty2 -canEq d fl ty1 ty2@(TyConApp fn tys) + = canEqLeaf loc ev ty1 ty2 +canEq loc ev ty1 ty2@(TyConApp fn tys) | isSynFamilyTyCon fn, length tys == tyConArity fn - = canEqLeaf d fl ty1 ty2 + = canEqLeaf loc ev ty1 ty2 -canEq d fl ty1 ty2 +canEq loc ev ty1 ty2 | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1 , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2 , isDecomposableTyCon tc1 && isDecomposableTyCon tc2 - = -- Generate equalities for each of the corresponding arguments - if (tc1 /= tc2 || length tys1 /= length tys2) - -- Fail straight away for better error messages - then canEqFailure d fl - else - do { let xcomp xs = EvCoercion (mkTcTyConAppCo tc1 (map evTermCoercion xs)) - xdecomp x = zipWith (\_ i -> EvCoercion $ mkTcNthCo i (evTermCoercion x)) tys1 [0..] - xev = XEvTerm xcomp xdecomp - ; ctevs <- xCtFlavor fl (zipWith mkTcEqPred tys1 tys2) xev - ; canEqEvVarsCreated d ctevs } + = canDecomposableTyConApp loc ev tc1 tys1 tc2 tys2 --- See Note [Equality between type applications] --- Note [Care with type applications] in TcUnify -canEq d fl ty1 ty2 -- e.g. F a b ~ Maybe c - -- where F has arity 1 - | Just (s1,t1) <- tcSplitAppTy_maybe ty1 - , Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = canEqAppTy d fl s1 t1 s2 t2 - -canEq d fl s1@(ForAllTy {}) s2@(ForAllTy {}) +canEq loc ev s1@(ForAllTy {}) s2@(ForAllTy {}) | tcIsForAllTy s1, tcIsForAllTy s2 - , Wanted { ctev_wloc = loc, ctev_evar = orig_ev } <- fl + , CtWanted { ctev_evar = orig_ev } <- ev = do { let (tvs1,body1) = tcSplitForAllTys s1 (tvs2,body2) = tcSplitForAllTys s2 ; if not (equalLength tvs1 tvs2) then - canEqFailure d fl + canEqFailure loc ev s1 s2 else - do { traceTcS "Creating implication for polytype equality" $ ppr fl + do { traceTcS "Creating implication for polytype equality" $ ppr ev ; deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2) ; return Stop } } | otherwise = do { traceTcS "Ommitting decomposition of given polytype equality" $ - pprEq s1 s2 + pprEq s1 s2 -- See Note [Do not decompose given polytype equalities] ; return Stop } -canEq d fl _ _ = canEqFailure d fl ------------------------- --- Type application -canEqAppTy :: SubGoalDepth - -> CtEvidence - -> Type -> Type -> Type -> Type - -> TcS StopOrContinue -canEqAppTy d fl s1 t1 s2 t2 - = ASSERT( not (isKind t1) && not (isKind t2) ) - if isGiven fl then - do { traceTcS "canEq (app case)" $ - text "Ommitting decomposition of given equality between: " - <+> ppr (AppTy s1 t1) <+> text "and" <+> ppr (AppTy s2 t2) - -- We cannot decompose given applications - -- because we no longer have 'left' and 'right' +-- The last remaining source of success is an application +-- e.g. F a b ~ Maybe c where F has arity 1 +-- See Note [Equality between type applications] +-- Note [Care with type applications] in TcUnify +canEq loc ev ty1 ty2 + = do { let flav = ctEvFlavour ev + ; (s1, co1) <- flatten loc FMSubstOnly flav ty1 + ; (s2, co2) <- flatten loc FMSubstOnly flav ty2 + ; mb_ct <- rewriteCtFlavor ev (mkTcEqPred s1 s2) (mkHdEqPred s2 co1 co2) + ; case mb_ct of + Nothing -> return Stop + Just new_ev -> last_chance new_ev s1 s2 } + where + last_chance ev ty1 ty2 + | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1 + , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2 + , isDecomposableTyCon tc1 && isDecomposableTyCon tc2 + = canDecomposableTyConApp loc ev tc1 tys1 tc2 tys2 + + | Just (s1,t1) <- tcSplitAppTy_maybe ty1 + , Just (s2,t2) <- tcSplitAppTy_maybe ty2 + = do { let xevcomp [x,y] = EvCoercion (mkTcAppCo (evTermCoercion x) (evTermCoercion y)) + xevcomp _ = error "canEqAppTy: can't happen" -- Can't happen + xevdecomp x = let xco = evTermCoercion x + in [EvCoercion (mkTcLRCo CLeft xco), EvCoercion (mkTcLRCo CRight xco)] + ; ctevs <- xCtFlavor ev [mkTcEqPred s1 s2, mkTcEqPred t1 t2] (XEvTerm xevcomp xevdecomp) + ; canEvVarsCreated loc ctevs } + + | otherwise + = do { emitInsoluble (CNonCanonical { cc_ev = ev, cc_loc = loc }) ; return Stop } - else - do { let xevcomp [x,y] = EvCoercion (mkTcAppCo (evTermCoercion x) (evTermCoercion y)) - xevcomp _ = error "canEqAppTy: can't happen" -- Can't happen - xev = XEvTerm { ev_comp = xevcomp - , ev_decomp = error "canEqAppTy: can't happen" } - ; ctevs <- xCtFlavor fl [mkTcEqPred s1 s2, mkTcEqPred t1 t2] xev - ; canEqEvVarsCreated d ctevs } -canEqFailure :: SubGoalDepth -> CtEvidence -> TcS StopOrContinue -canEqFailure d fl = emitFrozenError fl d >> return Stop +------------------------ +canDecomposableTyConApp :: CtLoc -> CtEvidence + -> TyCon -> [TcType] + -> TyCon -> [TcType] + -> TcS StopOrContinue +canDecomposableTyConApp loc ev tc1 tys1 tc2 tys2 + | tc1 /= tc2 || length tys1 /= length tys2 + -- Fail straight away for better error messages + = canEqFailure loc ev (mkTyConApp tc1 tys1) (mkTyConApp tc2 tys2) + | otherwise + = do { let xcomp xs = EvCoercion (mkTcTyConAppCo tc1 (map evTermCoercion xs)) + xdecomp x = zipWith (\_ i -> EvCoercion $ mkTcNthCo i (evTermCoercion x)) tys1 [0..] + xev = XEvTerm xcomp xdecomp + ; ctevs <- xCtFlavor ev (zipWith mkTcEqPred tys1 tys2) xev + ; canEvVarsCreated loc ctevs } + +canEqFailure :: CtLoc -> CtEvidence -> TcType -> TcType -> TcS StopOrContinue +-- See Note [Make sure that insolubles are fully rewritten] +canEqFailure loc ev ty1 ty2 + = do { let flav = ctEvFlavour ev + ; (s1, co1) <- flatten loc FMSubstOnly flav ty1 + ; (s2, co2) <- flatten loc FMSubstOnly flav ty2 + ; mb_ct <- rewriteCtFlavor ev (mkTcEqPred s1 s2) + (mkHdEqPred s2 co1 co2) + ; case mb_ct of + Just new_ev -> emitInsoluble (CNonCanonical { cc_ev = new_ev, cc_loc = loc }) + Nothing -> pprPanic "canEqFailure" (ppr ev $$ ppr ty1 $$ ppr ty2) + ; return Stop } ------------------------ emitKindConstraint :: Ct -> TcS StopOrContinue -emitKindConstraint ct +emitKindConstraint ct -- By now ct is canonical = case ct of - CTyEqCan { cc_depth = d - , cc_ev = fl, cc_tyvar = tv + CTyEqCan { cc_loc = loc + , cc_ev = ev, cc_tyvar = tv , cc_rhs = ty } - -> emit_kind_constraint d fl (mkTyVarTy tv) ty + -> emit_kind_constraint loc ev (mkTyVarTy tv) ty - CFunEqCan { cc_depth = d - , cc_ev = fl + CFunEqCan { cc_loc = loc + , cc_ev = ev , cc_fun = fn, cc_tyargs = xis1 , cc_rhs = xi2 } - -> emit_kind_constraint d fl (mkTyConApp fn xis1) xi2 + -> emit_kind_constraint loc ev (mkTyConApp fn xis1) xi2 _ -> continueWith ct where - emit_kind_constraint d fl ty1 ty2 + emit_kind_constraint loc _ev ty1 ty2 | compatKind k1 k2 -- True when ty1,ty2 are themselves kinds, = continueWith ct -- because then k1, k2 are BOX | otherwise = ASSERT( isKind k1 && isKind k2 ) - do { kev <- - do { mw <- newWantedEvVar kind_co_wloc (mkEqPred k1 k2) - ; case mw of - Cached ev_tm -> return ev_tm - Fresh ctev -> do { addToWork (canEq d ctev k1 k2) - ; return (ctEvTerm ctev) } } - - ; let xcomp [x] = mkEvKindCast x (evTermCoercion kev) - xcomp _ = panic "emit_kind_constraint:can't happen" - xdecomp x = [mkEvKindCast x (evTermCoercion kev)] - xev = XEvTerm xcomp xdecomp - - ; ctevs <- xCtFlavor_cache False fl [mkTcEqPred ty1 ty2] xev - -- Important: Do not cache original as Solved since we are supposed to - -- solve /exactly/ the same constraint later! Example: - -- (alpha :: kappa0) - -- (T :: *) - -- Equality is: (alpha ~ T), so we will emitConstraint (kappa0 ~ *) but - -- we don't want to say that (alpha ~ T) is now Solved! - - ; case ctevs of - [] -> return Stop - [new_ctev] -> continueWith (ct { cc_ev = new_ctev }) - _ -> panic "emitKindConstraint" } + do { mw <- newDerived (mkEqPred k1 k2) + ; case mw of + Nothing -> return () + Just kev -> emitWorkNC kind_co_loc [kev] + ; continueWith ct } where k1 = typeKind ty1 k2 = typeKind ty2 - ctxt = mkKindErrorCtxtTcS ty1 k1 ty2 k2 -- Always create a Wanted kind equality even if -- you are decomposing a given constraint. -- NB: DV finds this reasonable for now. Maybe we have to revisit. - kind_co_wloc = pushErrCtxtSameOrigin ctxt wanted_loc - wanted_loc = case fl of - Wanted { ctev_wloc = wloc } -> wloc - Derived { ctev_wloc = wloc } -> wloc - Given { ctev_gloc = gloc } -> setCtLocOrigin gloc orig - orig = TypeEqOrigin (UnifyOrigin ty1 ty2) + kind_co_loc = setCtLocOrigin loc (KindEqOrigin ty1 ty2 (ctLocOrigin loc)) \end{code} +Note [Make sure that insolubles are fully rewritten] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When an equality fails, we still want to rewrite the equality +all the way down, so that it accurately reflects + (a) the mutable reference substitution in force at start of solving + (b) any ty-binds in force at this point in solving +See Note [Kick out insolubles] in TcInteract. +And if we don't do this there is a bad danger that +TcSimplify.applyTyVarDefaulting will find a variable +that has in fact been substituted. + +Note [Do not decompose given polytype equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? +No -- what would the evidence look like. So instead we simply discard +this given evidence. + + Note [Combining insoluble constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As this point we have an insoluble constraint, like Int~Bool. @@ -1017,18 +1019,14 @@ inert set is an idempotent subustitution... \begin{code} data TypeClassifier - = FskCls TcTyVar -- ^ Flatten skolem - | VarCls TcTyVar -- ^ Non-flatten-skolem variable + = VarCls TcTyVar -- ^ Type variable | FunCls TyCon [Type] -- ^ Type function, exactly saturated | OtherCls TcType -- ^ Neither of the above classify :: TcType -> TypeClassifier -classify (TyVarTy tv) - | isTcTyVar tv, - FlatSkol {} <- tcTyVarDetails tv = FskCls tv - | otherwise = VarCls tv +classify (TyVarTy tv) = ASSERT2( isTcTyVar tv, ppr tv ) VarCls tv classify (TyConApp tc tys) | isSynFamilyTyCon tc , tyConArity tc == length tys = FunCls tc tys @@ -1046,38 +1044,23 @@ reOrient :: CtEvidence -> TypeClassifier -> TypeClassifier -> Bool -- We try to say False if possible, to minimise evidence generation -- -- Postcondition: After re-orienting, first arg is not OTherCls -reOrient _fl (OtherCls {}) (FunCls {}) = True -reOrient _fl (OtherCls {}) (FskCls {}) = True -reOrient _fl (OtherCls {}) (VarCls {}) = True -reOrient _fl (OtherCls {}) (OtherCls {}) = panic "reOrient" -- One must be Var/Fun - -reOrient _fl (FunCls {}) (VarCls _tv) = False - -- But consider the following variation: isGiven fl && isMetaTyVar tv +reOrient _ev (OtherCls {}) cls2 = ASSERT( case cls2 of { OtherCls {} -> False; _ -> True } ) + True -- One must be Var/Fun +reOrient _ev (FunCls {}) _ = False -- Fun/Other on rhs + -- But consider the following variation: isGiven ev && isMetaTyVar tv -- See Note [No touchables as FunEq RHS] in TcSMonad -reOrient _fl (FunCls {}) _ = False -- Fun/Other on rhs - -reOrient _fl (VarCls {}) (FunCls {}) = True - -reOrient _fl (VarCls {}) (FskCls {}) = False -reOrient _fl (VarCls {}) (OtherCls {}) = False -reOrient _fl (VarCls tv1) (VarCls tv2) +reOrient _ev (VarCls {}) (FunCls {}) = True +reOrient _ev (VarCls {}) (OtherCls {}) = False +reOrient _ev (VarCls tv1) (VarCls tv2) | isMetaTyVar tv2 && not (isMetaTyVar tv1) = True | otherwise = False -- Just for efficiency, see CTyEqCan invariants -reOrient _fl (FskCls {}) (VarCls tv2) = isMetaTyVar tv2 - -- Just for efficiency, see CTyEqCan invariants - -reOrient _fl (FskCls {}) (FskCls {}) = False -reOrient _fl (FskCls {}) (FunCls {}) = True -reOrient _fl (FskCls {}) (OtherCls {}) = False - ------------------ -canEqLeaf :: SubGoalDepth -- Depth - -> CtEvidence +canEqLeaf :: CtLoc -> CtEvidence -> Type -> Type -> TcS StopOrContinue -- Canonicalizing "leaf" equality constraints which cannot be @@ -1085,155 +1068,117 @@ canEqLeaf :: SubGoalDepth -- Depth -- saturated type function application). -- Preconditions: --- * one of the two arguments is variable or family applications +-- * one of the two arguments is variable +-- or an exactly-saturated family application -- * the two types are not equal (looking through synonyms) -canEqLeaf d fl s1 s2 +canEqLeaf loc ev s1 s2 | cls1 `re_orient` cls2 - = do { traceTcS "canEqLeaf (reorienting)" $ ppr fl <+> dcolon <+> pprEq s1 s2 + = do { traceTcS "canEqLeaf (reorienting)" $ ppr ev <+> dcolon <+> pprEq s1 s2 ; let xcomp [x] = EvCoercion (mkTcSymCo (evTermCoercion x)) xcomp _ = panic "canEqLeaf: can't happen" xdecomp x = [EvCoercion (mkTcSymCo (evTermCoercion x))] xev = XEvTerm xcomp xdecomp - ; ctevs <- xCtFlavor fl [mkTcEqPred s2 s1] xev + ; ctevs <- xCtFlavor ev [mkTcEqPred s2 s1] xev ; case ctevs of [] -> return Stop - [ctev] -> canEqLeafOriented d ctev s2 s1 + [ctev] -> canEqLeafOriented loc ctev cls2 s1 _ -> panic "canEqLeaf" } | otherwise = do { traceTcS "canEqLeaf" $ ppr (mkTcEqPred s1 s2) - ; canEqLeafOriented d fl s1 s2 } + ; canEqLeafOriented loc ev cls1 s2 } where - re_orient = reOrient fl + re_orient = reOrient ev cls1 = classify s1 cls2 = classify s2 -canEqLeafOriented :: SubGoalDepth -- Depth - -> CtEvidence - -> TcType -> TcType -> TcS StopOrContinue +canEqLeafOriented :: CtLoc -> CtEvidence + -> TypeClassifier -> TcType -> TcS StopOrContinue -- By now s1 will either be a variable or a type family application -canEqLeafOriented d fl s1 s2 - = can_eq_split_lhs d fl s1 s2 - where can_eq_split_lhs d fl s1 s2 - | Just (fn,tys1) <- splitTyConApp_maybe s1 - = canEqLeafFunEqLeftRec d fl (fn,tys1) s2 - | Just tv <- getTyVar_maybe s1 - = canEqLeafTyVarLeftRec d fl tv s2 - | otherwise - = pprPanic "canEqLeafOriented" $ - text "Non-variable or non-family equality LHS" <+> ppr (ctEvPred fl) - -canEqLeafFunEqLeftRec :: SubGoalDepth - -> CtEvidence - -> (TyCon,[TcType]) -> TcType -> TcS StopOrContinue -canEqLeafFunEqLeftRec d fl (fn,tys1) ty2 -- fl :: F tys1 ~ ty2 - = do { traceTcS "canEqLeafFunEqLeftRec" $ pprEq (mkTyConApp fn tys1) ty2 - ; (xis1,cos1) <- - {-# SCC "flattenMany" #-} - flattenMany d FMFullFlatten fl tys1 -- Flatten type function arguments - -- cos1 :: xis1 ~ tys1 +canEqLeafOriented loc ev (FunCls fn tys1) s2 = canEqLeafFunEq loc ev fn tys1 s2 +canEqLeafOriented loc ev (VarCls tv) s2 = canEqLeafTyVarEq loc ev tv s2 +canEqLeafOriented _ ev (OtherCls {}) _ = pprPanic "canEqLeafOriented" (ppr (ctEvPred ev)) + +canEqLeafFunEq :: CtLoc -> CtEvidence + -> TyCon -> [TcType] -> TcType -> TcS StopOrContinue +canEqLeafFunEq loc ev fn tys1 ty2 -- ev :: F tys1 ~ ty2 + = do { traceTcS "canEqLeafFunEq" $ pprEq (mkTyConApp fn tys1) ty2 + ; let flav = ctEvFlavour ev + + -- Flatten type function arguments + -- cos1 :: xis1 ~ tys1 + -- co2 :: xi2 ~ ty2 + ; (xis1,cos1) <- flattenMany loc FMFullFlatten flav tys1 + ; (xi2, co2) <- flatten loc FMFullFlatten flav ty2 + -- Fancy higher-dimensional coercion between equalities! + -- SPJ asks why? Why not just co : F xis1 ~ F tys1? ; let fam_head = mkTyConApp fn xis1 - -- Fancy higher-dimensional coercion between equalities! - ; let co = mkTcTyConAppCo eqTyCon $ - [mkTcReflCo (defaultKind $ typeKind ty2), mkTcTyConAppCo fn cos1, mkTcReflCo ty2] - -- Why defaultKind? Same reason as the comment on TcType/mkTcEqPred. I trully hate this (DV) - -- co :: (F xis1 ~ ty2) ~ (F tys1 ~ ty2) + xco = mkHdEqPred ty2 (mkTcTyConAppCo fn cos1) co2 + -- xco :: (F xis1 ~ xi2) ~ (F tys1 ~ ty2) - ; mb <- rewriteCtFlavor fl (mkTcEqPred fam_head ty2) co - ; case mb of - Nothing -> return Stop - Just new_fl -> canEqLeafFunEqLeft d new_fl (fn,xis1) ty2 } - - -canEqLeafFunEqLeft :: SubGoalDepth -- Depth - -> CtEvidence - -> (TyCon,[Xi]) - -> TcType -> TcS StopOrContinue --- Precondition: No more flattening is needed for the LHS -canEqLeafFunEqLeft d fl (fn,xis1) s2 - = {-# SCC "canEqLeafFunEqLeft" #-} - do { traceTcS "canEqLeafFunEqLeft" $ pprEq (mkTyConApp fn xis1) s2 - ; (xi2,co2) <- - {-# SCC "flatten" #-} - flatten d FMFullFlatten fl s2 -- co2 :: xi2 ~ s2 - - ; let fam_head = mkTyConApp fn xis1 - -- Fancy coercion between equalities! But it should just work! - ; let co = mkTcTyConAppCo eqTyCon $ [ mkTcReflCo (defaultKind $ typeKind s2) - , mkTcReflCo fam_head, co2 ] - -- Why defaultKind? Same reason as the comment at TcType/mkTcEqPred - -- co :: (F xis1 ~ xi2) ~ (F xis1 ~ s2) - -- new pred old pred - ; mb <- rewriteCtFlavor fl (mkTcEqPred fam_head xi2) co - ; case mb of - Nothing -> return Stop - Just new_fl -> continueWith $ - CFunEqCan { cc_ev = new_fl, cc_depth = d - , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } } - - -canEqLeafTyVarLeftRec :: SubGoalDepth - -> CtEvidence - -> TcTyVar -> TcType -> TcS StopOrContinue -canEqLeafTyVarLeftRec d fl tv s2 -- fl :: tv ~ s2 - = do { traceTcS "canEqLeafTyVarLeftRec" $ pprEq (mkTyVarTy tv) s2 - ; (xi1,co1) <- flattenTyVar d FMFullFlatten fl tv -- co1 :: xi1 ~ tv - ; let is_still_var = isJust (getTyVar_maybe xi1) - - ; traceTcS "canEqLeafTyVarLeftRec2" $ empty - - ; let co = mkTcTyConAppCo eqTyCon $ [ mkTcReflCo (defaultKind $ typeKind s2) - , co1, mkTcReflCo s2] - -- co :: (xi1 ~ s2) ~ (tv ~ s2) - ; mb <- rewriteCtFlavor_cache (if is_still_var then False else True) fl (mkTcEqPred xi1 s2) co - -- See Note [Caching loops] - - ; traceTcS "canEqLeafTyVarLeftRec3" $ empty - - ; case mb of - Nothing -> return Stop - Just new_fl -> - case getTyVar_maybe xi1 of - Just tv' -> canEqLeafTyVarLeft d new_fl tv' s2 - Nothing -> canEq d new_fl xi1 s2 } - -canEqLeafTyVarLeft :: SubGoalDepth -- Depth - -> CtEvidence + ; mb <- rewriteCtFlavor ev (mkTcEqPred fam_head xi2) xco + ; case mb of { + Nothing -> return Stop ; + Just new_ev -> continueWith new_ct +-- | isTcReflCo xco -> continueWith new_ct +-- | otherwise -> do { updWorkListTcS (extendWorkListFunEq new_ct); return Stop } + where + new_ct = CFunEqCan { cc_ev = new_ev, cc_loc = loc + , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } } } + + +canEqLeafTyVarEq :: CtLoc -> CtEvidence -> TcTyVar -> TcType -> TcS StopOrContinue --- Precondition LHS is fully rewritten from inerts (but not RHS) -canEqLeafTyVarLeft d fl tv s2 -- eqv : tv ~ s2 - = do { let tv_ty = mkTyVarTy tv - ; traceTcS "canEqLeafTyVarLeft" (pprEq tv_ty s2) - ; (xi2, co2) <- flatten d FMFullFlatten fl s2 -- Flatten RHS co:xi2 ~ s2 - - ; traceTcS "canEqLeafTyVarLeft" (nest 2 (vcat [ text "tv =" <+> ppr tv - , text "s2 =" <+> ppr s2 - , text "xi2 =" <+> ppr xi2])) - - -- Reflexivity exposed through flattening - ; if tv_ty `eqType` xi2 then - when (isWanted fl) (setEvBind (ctev_evar fl) (EvCoercion co2)) >> - return Stop - else do - -- Not reflexivity but maybe an occurs error - { let occ_check_result = occurCheckExpand tv xi2 - xi2' = fromMaybe xi2 occ_check_result - - not_occ_err = isJust occ_check_result - -- Delicate: don't want to cache as solved a constraint with occurs error! - co = mkTcTyConAppCo eqTyCon $ - [mkTcReflCo (defaultKind $ typeKind s2), mkTcReflCo tv_ty, co2] - ; mb <- rewriteCtFlavor_cache not_occ_err fl (mkTcEqPred tv_ty xi2') co - ; case mb of - Just new_fl -> if not_occ_err then - continueWith $ - CTyEqCan { cc_ev = new_fl, cc_depth = d - , cc_tyvar = tv, cc_rhs = xi2' } - else - canEqFailure d new_fl - Nothing -> return Stop - } } +canEqLeafTyVarEq loc ev tv s2 -- ev :: tv ~ s2 + = do { traceTcS "canEqLeafTyVarEq" $ pprEq (mkTyVarTy tv) s2 + ; let flav = ctEvFlavour ev + ; (xi1,co1) <- flattenTyVar loc FMFullFlatten flav tv -- co1 :: xi1 ~ tv + ; (xi2,co2) <- flatten loc FMFullFlatten flav s2 -- co2 :: xi2 ~ s2 + ; let co = mkHdEqPred s2 co1 co2 + -- co :: (xi1 ~ xi2) ~ (tv ~ s2) + + ; traceTcS "canEqLeafTyVarEq2" $ empty + ; case (getTyVar_maybe xi1, getTyVar_maybe xi2) of { + (Nothing, _) -> -- Rewriting the LHS did not yield a type variable + -- so go around again to canEq + do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2) co + ; case mb of + Nothing -> return Stop + Just new_ev -> canEq loc new_ev xi1 xi2 } ; + + (Just tv1', Just tv2') | tv1' == tv2' + -> do { when (isWanted ev) $ + setEvBind (ctev_evar ev) (mkEvCast (EvCoercion (mkTcReflCo xi1)) co) + ; return Stop } ; + + (Just tv1', _) -> + + -- LHS rewrote to a type variable, RHS to something else + case occurCheckExpand tv1' xi2 of + Nothing -> -- Occurs check error + do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2) co + ; case mb of + Nothing -> return Stop + Just new_ev -> canEqFailure loc new_ev xi1 xi2 } + + Just xi2' -> -- No occurs check, so we can continue; but make sure + -- that the new goal has enough type synonyms expanded by + -- by the occurCheckExpand + do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2') co + ; case mb of + Nothing -> return Stop + Just new_ev -> continueWith $ + CTyEqCan { cc_ev = new_ev, cc_loc = loc + , cc_tyvar = tv1', cc_rhs = xi2' } } + } } + +mkHdEqPred :: Type -> TcCoercion -> TcCoercion -> TcCoercion +-- Make a higher-dimensional equality +-- co1 :: s1~t1, co2 :: s2~t2 +-- Then (mkHdEqPred t2 co1 co2) :: (s1~s2) ~ (t1~t2) +mkHdEqPred t2 co1 co2 = mkTcTyConAppCo eqTyCon [mkTcReflCo (defaultKind (typeKind t2)), co1, co2] + -- Why defaultKind? Same reason as the comment on TcType/mkTcEqPred. I truly hate this (DV) \end{code} Note [Occurs check expansion] diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 209215e8ec..7df818efd2 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -197,10 +197,10 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) DefMeth dm_name -> tc_dm dm_name GenDefMeth dm_name -> tc_dm dm_name where - sel_name = idName sel_id - prags = prag_fn sel_name - dm_bind = findMethodBind sel_name binds_in - `orElse` pprPanic "tcDefMeth" (ppr sel_id) + sel_name = idName sel_id + prags = prag_fn sel_name + (dm_bind,bndr_loc) = findMethodBind sel_name binds_in + `orElse` pprPanic "tcDefMeth" (ppr sel_id) -- Eg. class C a where -- op :: forall b. Eq b => a -> [b] -> a @@ -211,11 +211,10 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) tc_dm dm_name = do { dm_id <- tcLookupId dm_name - ; local_dm_name <- newLocalName sel_name + ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name) -- Base the local_dm_name on the selector name, because -- type errors from tcInstanceMethodBody come from here - ; dm_id_w_inline <- addInlinePrags dm_id prags ; spec_prags <- tcSpecPrags dm_id prags @@ -242,17 +241,13 @@ tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] tcInstanceMethodBody skol_info tyvars dfun_ev_vars meth_id local_meth_sig specs (L loc bind) - = do { -- Typecheck the binding, first extending the envt - -- so that when tcInstSig looks up the local_meth_id to find - -- its signature, we'll find it in the environment - let local_meth_id = sig_id local_meth_sig + = do { let local_meth_id = sig_id local_meth_sig lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind ; (ev_binds, (tc_bind, _, _)) <- checkConstraints skol_info tyvars dfun_ev_vars $ - tcExtendIdEnv [local_meth_id] $ - tcPolyCheck local_meth_sig no_prag_fn NonRecursive [lm_bind] + tcPolyCheck NotTopLevel NonRecursive no_prag_fn local_meth_sig [lm_bind] ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id , abe_mono = local_meth_id, abe_prags = specs } @@ -308,13 +303,15 @@ lookupHsSig = lookupNameEnv --------------------------- findMethodBind :: Name -- Selector name -> LHsBinds Name -- A group of bindings - -> Maybe (LHsBind Name) -- The binding + -> Maybe (LHsBind Name, SrcSpan) + -- Returns the binding, and the binding + -- site of the method binder findMethodBind sel_name binds = foldlBag mplus Nothing (mapBag f binds) where - f bind@(L _ (FunBind { fun_id = L _ op_name })) + f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) | op_name == sel_name - = Just bind + = Just (bind, bndr_loc) f _other = Nothing \end{code} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index fa4fc40ddc..3249f54bc1 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -25,6 +25,8 @@ module TcEnv( tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendGhciEnv, tcExtendLetEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, + tcExtendIdBndrs, + tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, tcLookupLcl_maybe, @@ -375,27 +377,36 @@ tcExtendLetEnv closed ids thing_inside ; tc_extend_local_env [ (idName id, ATcId { tct_id = id , tct_closed = closed , tct_level = thLevel stage }) - | id <- ids] - thing_inside } + | id <- ids] $ + tcExtendIdBndrs [TcIdBndr id closed | id <- ids] thing_inside } tcExtendIdEnv :: [TcId] -> TcM a -> TcM a tcExtendIdEnv ids thing_inside - = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside + = tcExtendIdEnv2 [(idName id, id) | id <- ids] $ + tcExtendIdBndrs [TcIdBndr id NotTopLevel | id <- ids] + thing_inside tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a tcExtendIdEnv1 name id thing_inside - = tcExtendIdEnv2 [(name,id)] thing_inside + = tcExtendIdEnv2 [(name,id)] $ + tcExtendIdBndrs [TcIdBndr id NotTopLevel] + thing_inside tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a +-- Do *not* extend the tcl_bndrs stack +-- The tct_closed flag really doesn't matter -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) tcExtendIdEnv2 names_w_ids thing_inside = do { stage <- getStage ; tc_extend_local_env [ (name, ATcId { tct_id = id , tct_closed = NotTopLevel , tct_level = thLevel stage }) - | (name,id) <- names_w_ids] + | (name,id) <- names_w_ids] $ thing_inside } +tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a +tcExtendIdBndrs bndrs = updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) + tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction -- Note especially that we bind them at diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index bbf5ae6181..0fb0194d25 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -8,16 +8,16 @@ -- for details module TcErrors( - reportUnsolved, ErrEnv, + reportUnsolved, reportAllUnsolved, warnDefaulting, - flattenForAllErrorTcS, solverDepthErrorTcS ) where #include "HsVersions.h" import TcCanonical( occurCheckExpand ) +import TcRnTypes import TcRnMonad import TcMType import TcType @@ -30,18 +30,18 @@ import InstEnv import TyCon import TcEvidence import Name -import NameEnv -import Id ( idType ) +import Id import Var import VarSet import VarEnv import Bag import Maybes import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg ) -import SrcLoc ( noSrcSpan ) +import BasicTypes import Util import FastString import Outputable +import SrcLoc import DynFlags import Data.List ( partition, mapAccumL ) \end{code} @@ -56,45 +56,88 @@ ToDo: for these error messages, should we note the location as coming from the insts, or just whatever seems to be around in the monad just now? -\begin{code} --- We keep an environment mapping coercion ids to the error messages they --- trigger; this is handy for -fwarn--type-errors -type ErrEnv = VarEnv [ErrMsg] +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: + + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in TcUnify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co -reportUnsolved :: Bool -> WantedConstraints -> TcM (Bag EvBind) -reportUnsolved runtimeCoercionErrors wanted +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in TcErrors. TcErrors.reportTidyWanteds does not print the errors +and does not fail if -fwarn-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. + +\begin{code} +reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) +reportUnsolved wanted + = do { binds_var <- newTcEvBinds + ; defer <- doptM Opt_DeferTypeErrors + ; report_unsolved (Just binds_var) defer wanted + ; getTcEvBinds binds_var } + +reportAllUnsolved :: WantedConstraints -> TcM () +-- Report all unsolved goals, even if -fdefer-type-errors is on +-- See Note [Deferring coercion errors to runtime] +reportAllUnsolved wanted = report_unsolved Nothing False wanted + +report_unsolved :: Maybe EvBindsVar -- cec_binds + -> Bool -- cec_defer + -> WantedConstraints -> TcM () +-- Important precondition: +-- WantedConstraints are fully zonked and unflattened, that is, +-- zonkWC has already been applied to these constraints. +report_unsolved mb_binds_var defer wanted | isEmptyWC wanted - = return emptyBag + = return () | otherwise - = do { -- Zonk to un-flatten any flatten-skols - wanted <- zonkWC wanted + = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted) ; env0 <- tcInitTidyEnv - ; defer <- if runtimeCoercionErrors - then do { ev <- newTcEvBinds - ; return (Just ev) } - else return Nothing - - ; errs_so_far <- ifErrsM (return True) (return False) + + -- If we are deferring we are going to need /all/ evidence around, + -- including the evidence produced by unflattening (zonkWC) +-- ; errs_so_far <- ifErrsM (return True) (return False) ; let tidy_env = tidyFreeTyVars env0 free_tvs free_tvs = tyVarsOfWC wanted err_ctxt = CEC { cec_encl = [] - , cec_insol = errs_so_far || insolubleWC wanted - -- Don't report ambiguity errors if - -- there are any other solid errors - -- to report - , cec_extra = empty , cec_tidy = tidy_env - , cec_defer = defer } - - ; traceTc "reportUnsolved:" (vcat [ pprTvBndrs (varSetElems free_tvs) - , ppr wanted ]) + , cec_defer = defer + , cec_suppress = insolubleWC wanted + -- Suppress all but insolubles if there are + -- any insoulubles, or earlier errors + , cec_binds = mb_binds_var } - ; reportWanteds err_ctxt wanted + ; traceTc "reportUnsolved (after unflattening):" $ + vcat [ pprTvBndrs (varSetElems free_tvs) + , ppr wanted ] - ; case defer of - Nothing -> return emptyBag - Just ev -> getTcEvBinds ev } + ; reportWanteds err_ctxt wanted } -------------------------------------------- -- Internal functions @@ -105,106 +148,85 @@ data ReportErrCtxt -- (innermost first) -- ic_skols and givens are tidied, rest are not , cec_tidy :: TidyEnv - , cec_extra :: SDoc -- Add this to each error message - , cec_insol :: Bool -- True <=> do not report errors involving - -- ambiguous errors - , cec_defer :: Maybe EvBindsVar - -- Nothinng <=> errors are, well, errors - -- Just ev <=> make errors into warnings, and emit evidence - -- bindings into 'ev' for unsolved constraints + , cec_binds :: Maybe EvBindsVar + -- Nothinng <=> Report all errors, including holes; no bindings + -- Just ev <=> make some errors (depending on cec_defer) + -- into warnings, and emit evidence bindings + -- into 'ev' for unsolved constraints + + , cec_defer :: Bool -- True <=> -fdefer-type-errors + -- Irrelevant if cec_binds = Nothing + , cec_suppress :: Bool -- True <=> More important errors have occurred, + -- so create bindings if need be, but + -- don't issue any more errors/warnings } reportImplic :: ReportErrCtxt -> Implication -> TcM () reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given , ic_wanted = wanted, ic_binds = evb - , ic_insol = insoluble, ic_loc = loc }) - | BracketSkol <- ctLocOrigin loc - , not insoluble -- For Template Haskell brackets report only - = return () -- definite errors. The whole thing will be re-checked - -- later when we plug it in, and meanwhile there may - -- certainly be un-satisfied constraints + , ic_insol = ic_insoluble, ic_info = info }) + | BracketSkol <- info + , not ic_insoluble -- For Template Haskell brackets report only + = return () -- definite errors. The whole thing will be re-checked + -- later when we plug it in, and meanwhile there may + -- certainly be un-satisfied constraints | otherwise = reportWanteds ctxt' wanted where (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs + (env2, info') = tidySkolemInfo env1 info implic' = implic { ic_skols = tvs' - , ic_given = map (tidyEvVar env1) given - , ic_loc = tidyGivenLoc env1 loc } - ctxt' = ctxt { cec_tidy = env1 + , ic_given = map (tidyEvVar env2) given + , ic_info = info' } + ctxt' = ctxt { cec_tidy = env2 , cec_encl = implic' : cec_encl ctxt - , cec_defer = case cec_defer ctxt of + , cec_binds = case cec_binds ctxt of Nothing -> Nothing Just {} -> Just evb } reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) - = reportTidyWanteds ctxt tidy_insols tidy_flats implics + = do { reportFlats (ctxt { cec_suppress = False }) (mapBag (tidyCt env) insols) + ; reportFlats ctxt (mapBag (tidyCt env) flats) + ; mapBagM_ (reportImplic ctxt) implics } where env = cec_tidy ctxt - tidy_insols = mapBag (tidyCt env) insols - tidy_flats = mapBag (tidyCt env) (keepWanted flats) +-- tidy_cts = mapBag (tidyCt env) (insols `unionBags` flats) + -- All the Derived ones have been filtered out alrady + -- by the constraint solver. This is ok; we don't want + -- to report unsolved Derived goals as error -- See Note [Do not report derived but soluble errors] -reportTidyWanteds :: ReportErrCtxt -> Bag Ct -> Bag Ct -> Bag Implication -> TcM () -reportTidyWanteds ctxt insols flats implics - | Just ev_binds_var <- cec_defer ctxt - = do { -- Defer errors to runtime - -- See Note [Deferring coercion errors to runtime] in TcSimplify - mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) - (flats `unionBags` insols) - ; mapBagM_ (reportImplic ctxt) implics } - - | otherwise - = do { reportInsolsAndFlats ctxt insols flats - ; mapBagM_ (reportImplic ctxt) implics } - - -deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) - -> Ct -> TcM () -deferToRuntime ev_binds_var ctxt mk_err_msg ct - | Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct - = do { err <- setCtLoc loc $ - mk_err_msg ctxt ct - ; dflags <- getDynFlags - ; let err_msg = pprLocErrMsg err - err_fs = mkFastString $ showSDoc dflags $ - err_msg $$ text "(deferred type error)" - - -- Create the binding - ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) - - -- And emit a warning - ; reportWarning (makeIntoWarning err) } - - | otherwise -- Do not set any evidence for Given/Derived - = return () - -reportInsolsAndFlats :: ReportErrCtxt -> Cts -> Cts -> TcM () -reportInsolsAndFlats ctxt insols flats - = tryReporters +reportFlats :: ReportErrCtxt -> Cts -> TcM () +reportFlats ctxt flats -- Here 'flats' includes insolble goals + = traceTc "reportFlats" (ppr flats) >> + tryReporters [ -- First deal with things that are utterly wrong -- Like Int ~ Bool (incl nullary TyCons) -- or Int ~ t a (AppTy on one side) - ("Utterly wrong", utterly_wrong, groupErrs (mkEqErr ctxt)) + ("Utterly wrong", utterly_wrong, mkGroupReporter mkEqErr) + , ("Holes", is_hole, mkUniReporter mkHoleError) -- Report equalities of form (a~ty). They are usually -- skolem-equalities, and they cause confusing knock-on -- effects in other errors; see test T4093b. - , ("Skolem equalities", skolem_eq, mkReporter (mkEqErr1 ctxt)) - - , ("Unambiguous", unambiguous, reportFlatErrs ctxt) ] - (reportAmbigErrs ctxt) - (bagToList (insols `unionBags` flats)) + , ("Skolem equalities", skolem_eq, mkUniReporter mkEqErr1) ] +-- , ("Unambiguous", unambiguous, reportFlatErrs) ] + reportFlatErrs + ctxt (bagToList flats) where - utterly_wrong, skolem_eq, unambiguous :: Ct -> PredTree -> Bool - + utterly_wrong, skolem_eq :: Ct -> PredTree -> Bool utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2 utterly_wrong _ _ = False + is_hole ct _ = isHoleCt ct + skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 skolem_eq _ _ = False +{- + unambiguous :: Ct -> PredTree -> Bool unambiguous ct pred | not (any isAmbiguousTyVar (varSetElems (tyVarsOfCt ct))) = True @@ -212,6 +234,7 @@ reportInsolsAndFlats ctxt insols flats = case pred of EqPred ty1 ty2 -> isNothing (isTyFun_maybe ty1) && isNothing (isTyFun_maybe ty2) _ -> False +-} --------------- isRigid, isRigidOrSkol :: Type -> Bool @@ -231,63 +254,18 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of _ -> Nothing ----------------- -type Reporter = [Ct] -> TcM () - -mkReporter :: (Ct -> TcM ErrMsg) -> [Ct] -> TcM () --- Reports errors one at a time -mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_ev ct) $ - mk_err ct; - ; reportError err }) - -tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] -> Reporter -> Reporter --- Use the first reporter in the list whose predicate says True -tryReporters reporters deflt cts - = do { traceTc "tryReporters {" (ppr cts) - ; go reporters cts - ; traceTc "tryReporters }" empty } - where - go [] cts = deflt cts - go ((str, pred, reporter) : rs) cts - | null yeses = traceTc "tryReporters: no" (text str) >> - go rs cts - | otherwise = traceTc "tryReporters: yes" (text str <+> ppr yeses) >> - reporter yeses - where - yeses = filter keep_me cts - keep_me ct = pred ct (classifyPredType (ctPred ct)) - ------------------ -mkFlatErr :: ReportErrCtxt -> Ct -> TcM ErrMsg --- Context is already set -mkFlatErr ctxt ct -- The constraint is always wanted - | isIPPred (ctPred ct) = mkIPErr ctxt [ct] - | otherwise - = case classifyPredType (ctPred ct) of - ClassPred {} -> mkDictErr ctxt [ct] - IrredPred {} -> mkIrredErr ctxt [ct] - EqPred {} -> mkEqErr1 ctxt ct - TuplePred {} -> panic "mkFlat" - -reportAmbigErrs :: ReportErrCtxt -> Reporter -reportAmbigErrs ctxt cts - | cec_insol ctxt = return () - | otherwise = reportFlatErrs ctxt cts - -- Only report ambiguity if no other errors (at all) happened - -- See Note [Avoiding spurious errors] in TcSimplify - -reportFlatErrs :: ReportErrCtxt -> Reporter +reportFlatErrs :: Reporter -- Called once for non-ambigs, once for ambigs -- Report equality errors, and others only if we've done all -- the equalities. The equality errors are more basic, and -- can lead to knock on type-class errors -reportFlatErrs ctxt cts +reportFlatErrs = tryReporters - [ ("Equalities", is_equality, groupErrs (mkEqErr ctxt)) ] - (\cts -> do { let (dicts, ips, irreds) = go cts [] [] [] - ; groupErrs (mkIPErr ctxt) ips - ; groupErrs (mkIrredErr ctxt) irreds - ; groupErrs (mkDictErr ctxt) dicts }) - cts + [ ("Equalities", is_equality, mkGroupReporter mkEqErr) ] + (\ctxt cts -> do { let (dicts, ips, irreds) = go cts [] [] [] + ; mkGroupReporter mkIPErr ctxt ips + ; mkGroupReporter mkIrredErr ctxt irreds + ; mkGroupReporter mkDictErr ctxt dicts }) where is_equality _ (EqPred {}) = True is_equality _ _ = False @@ -295,53 +273,111 @@ reportFlatErrs ctxt cts go [] dicts ips irreds = (dicts, ips, irreds) go (ct:cts) dicts ips irreds - | isIPPred (ctPred ct) = go cts dicts (ct:ips) irreds + | isIPPred (ctPred ct) + = go cts dicts (ct:ips) irreds | otherwise = case classifyPredType (ctPred ct) of ClassPred {} -> go cts (ct:dicts) ips irreds IrredPred {} -> go cts dicts ips (ct:irreds) - _ -> panic "mkFlat" + _ -> panic "reportFlatErrs" -- TuplePreds should have been expanded away by the constraint -- simplifier, so they shouldn't show up at this point -- And EqPreds are dealt with by the is_equality test -------------------------------------------- --- Support code +-- Reporters -------------------------------------------- -groupErrs :: ([Ct] -> TcM ErrMsg) -- Deal with one group - -> [Ct] -- Unsolved wanteds - -> TcM () +type Reporter = ReportErrCtxt -> [Ct] -> TcM () + +mkUniReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter +-- Reports errors one at a time +mkUniReporter mk_err ctxt + = mapM_ $ \ct -> + do { err <- mk_err ctxt ct + ; maybeReportError ctxt err ct + ; maybeAddDeferredBinding ctxt err ct } + +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) + -- Make error message for a group + -> Reporter -- Deal with lots of constraints -- Group together insts from same location -- We want to report them together in error messages -groupErrs _ [] +mkGroupReporter _ _ [] = return () -groupErrs mk_err (ct1 : rest) - = do { err <- setCtFlavorLoc flavor $ mk_err cts - ; reportError err - ; groupErrs mk_err others } +mkGroupReporter mk_err ctxt (ct1 : rest) + = do { err <- mk_err ctxt cts + ; maybeReportError ctxt err ct1 + ; mapM_ (maybeAddDeferredBinding ctxt err) (ct1:rest) + -- Add deferred bindings for all + ; mkGroupReporter mk_err ctxt others } where - flavor = cc_ev ct1 + loc = cc_loc ct1 cts = ct1 : friends (friends, others) = partition is_friend rest - is_friend friend = cc_ev friend `same_group` flavor + is_friend friend = cc_loc friend `same_loc` loc - same_group :: CtEvidence -> CtEvidence -> Bool - same_group (Given {ctev_gloc = l1}) (Given {ctev_gloc = l2}) = same_loc l1 l2 - same_group (Wanted {ctev_wloc = l1}) (Wanted {ctev_wloc = l2}) = same_loc l1 l2 - same_group (Derived {ctev_wloc = l1}) (Derived {ctev_wloc = l2}) = same_loc l1 l2 - same_group _ _ = False + same_loc :: CtLoc -> CtLoc -> Bool + same_loc l1 l2 = ctLocSpan l1 == ctLocSpan l2 + +maybeReportError :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () +-- Report the error and/or make a deferred binding for it +maybeReportError ctxt err ct + | cec_suppress ctxt + = return () + | isHoleCt ct || cec_defer ctxt -- And it's a hole or we have -fdefer-type-errors + = reportWarning (makeIntoWarning err) + | otherwise + = reportError err + +maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () +-- See Note [Deferring coercion errors to runtime] +maybeAddDeferredBinding ctxt err ct + | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct + -- Only add deferred bindings for Wanted constraints + , isHoleCt ct || cec_defer ctxt -- And it's a hole or we have -fdefer-type-errors + , Just ev_binds_var <- cec_binds ctxt -- We hvae somewhere to put the bindings + = do { dflags <- getDynFlags + ; let err_msg = pprLocErrMsg err + err_fs = mkFastString $ showSDoc dflags $ + err_msg $$ text "(deferred type error)" - same_loc :: CtLoc o -> CtLoc o -> Bool - same_loc (CtLoc _ s1 _) (CtLoc _ s2 _) = s1==s2 + -- Create the binding + ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) } + + | otherwise -- Do not set any evidence for Given/Derived + = return () + +tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] + -> Reporter -> Reporter +-- Use the first reporter in the list whose predicate says True +tryReporters reporters deflt ctxt cts + = do { traceTc "tryReporters {" (ppr cts) + ; go ctxt reporters cts + ; traceTc "tryReporters }" empty } + where + go ctxt [] cts = deflt ctxt cts + go ctxt ((str, pred, reporter) : rs) cts + | null yeses = do { traceTc "tryReporters: no" (text str) + ; go ctxt rs cts } + | otherwise = do { traceTc "tryReporters: yes" (text str <+> ppr yeses) + ; reporter ctxt yeses :: TcM () + ; go (ctxt { cec_suppress = True }) rs nos } + -- Carry on with the rest, because we must make + -- deferred bindings for them if we have + -- -fdefer-type-errors + -- But suppress their error messages + where + (yeses, nos) = partition keep_me cts + keep_me ct = pred ct (classifyPredType (ctPred ct)) -- Add the "arising from..." part to a message about bunch of dicts addArising :: CtOrigin -> SDoc -> SDoc addArising orig msg = hang msg 2 (pprArising orig) -pprWithArising :: [Ct] -> (WantedLoc, SDoc) +pprWithArising :: [Ct] -> (CtLoc, SDoc) -- Print something like -- (Eq a) arising from a use of x at y -- (Show a) arising from a use of p at q @@ -351,26 +387,30 @@ pprWithArising [] = panic "pprWithArising" pprWithArising (ct:cts) | null cts - = (loc, addArising (ctLocOrigin (ctWantedLoc ct)) + = (loc, addArising (ctLocOrigin loc) (pprTheta [ctPred ct])) | otherwise = (loc, vcat (map ppr_one (ct:cts))) where - loc = ctWantedLoc ct + loc = cc_loc ct ppr_one ct = hang (parens (pprType (ctPred ct))) - 2 (pprArisingAt (ctWantedLoc ct)) + 2 (pprArisingAt (cc_loc ct)) -mkErrorReport :: ReportErrCtxt -> SDoc -> TcM ErrMsg -mkErrorReport ctxt msg = mkErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) +mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg +mkErrorMsg ctxt ct msg + = do { let tcl_env = ctLocEnv (cc_loc ct) + ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) + ; mkLongErrAt (tcl_loc tcl_env) msg err_info } -type UserGiven = ([EvVar], GivenLoc) +type UserGiven = ([EvVar], SkolemInfo, SrcSpan) getUserGivens :: ReportErrCtxt -> [UserGiven] -- One item for each enclosing implication getUserGivens (CEC {cec_encl = ctxt}) = reverse $ - [ (givens, loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt - , not (null givens) ] + [ (givens, info, tcl_loc env) + | Implic {ic_given = givens, ic_env = env, ic_info = info } <- ctxt + , not (null givens) ] \end{code} Note [Do not report derived but soluble errors] @@ -432,29 +472,44 @@ solve it. \begin{code} mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkIrredErr ctxt cts - = mkErrorReport ctxt msg + = do { (ctxt, binds_msg) <- relevantBindings ctxt ct1 + ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) } where (ct1:_) = cts - orig = ctLocOrigin (ctWantedLoc ct1) + orig = ctLocOrigin (cc_loc ct1) givens = getUserGivens ctxt msg = couldNotDeduce givens (map ctPred cts, orig) -\end{code} +---------------- +mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg +mkHoleError ctxt ct@(CHoleCan {}) + = do { let tyvars = varSetElems (tyVarsOfCt ct) + tyvars_msg = map loc_msg tyvars + msg = (text "Found hole" <+> quotes (text "_") + <+> text "with type") <+> pprType (ctEvPred (cc_ev ct)) + $$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg) + ; (ctxt, binds_doc) <- relevantBindings ctxt ct + ; mkErrorMsg ctxt ct (msg $$ binds_doc) } + where + loc_msg tv + = case tcTyVarDetails tv of + SkolemTv {} -> quotes (ppr tv) <+> skol_msg + MetaTv {} -> quotes (ppr tv) <+> text "is a free type variable" + det -> pprTcTyVarDetails det + where + skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv) -%************************************************************************ -%* * - Implicit parameter errors -%* * -%************************************************************************ +mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct) -\begin{code} +---------------- mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkIPErr ctxt cts - = do { (ctxt', _, ambig_err) <- mkAmbigMsg ctxt cts - ; mkErrorReport ctxt' (msg $$ ambig_err) } + = do { (ctxt, _, ambig_err) <- mkAmbigMsg ctxt cts + ; (ctxt, bind_msg) <- relevantBindings ctxt ct1 + ; mkErrorMsg ctxt ct1 (msg $$ ambig_err $$ bind_msg) } where (ct1:_) = cts - orig = ctLocOrigin (ctWantedLoc ct1) + orig = ctLocOrigin (cc_loc ct1) preds = map ctPred cts givens = getUserGivens ctxt msg | null givens @@ -482,111 +537,110 @@ mkEqErr _ [] = panic "mkEqErr" mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg -- Wanted constraints only! mkEqErr1 ctxt ct - = if isGiven flav then - let ctx2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg flav } - in mkEqErr_help ctx2 ct False ty1 ty2 - else - do { let orig = ctLocOrigin (getWantedLoc flav) - ; (ctxt1, orig') <- zonkTidyOrigin ctxt orig - ; mk_err ctxt1 orig' } + = do { (ctxt, binds_msg) <- relevantBindings ctxt ct + ; (ctxt, orig) <- zonkTidyOrigin ctxt orig + ; let (is_oriented, wanted_msg) = mk_wanted_extra orig + ; if isGiven ev then + mkEqErr_help ctxt (inaccessible_msg orig $$ binds_msg) ct Nothing ty1 ty2 + else + mkEqErr_help ctxt (wanted_msg $$ binds_msg) ct is_oriented ty1 ty2 } where - - flav = cc_ev ct - - inaccessible_msg (Given { ctev_gloc = loc }) - = hang (ptext (sLit "Inaccessible code in")) - 2 (ppr (ctLocOrigin loc)) - -- If a Solved then we should not report inaccessible code - inaccessible_msg _ = empty - + ev = cc_ev ct + orig = ctLocOrigin (cc_loc ct) (ty1, ty2) = getEqPredTys (ctPred ct) + inaccessible_msg orig = hang (ptext (sLit "Inaccessible code in")) + 2 (ppr orig) + -- If the types in the error message are the same as the types -- we are unifying, don't add the extra expected/actual message - mk_err ctxt1 (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) - | act `pickyEqType` ty1 - , exp `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True ty2 ty1 - | exp `pickyEqType` ty1 - , act `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True ty1 ty2 - | otherwise = mkEqErr_help ctxt2 ct False ty1 ty2 + mk_wanted_extra orig@(TypeEqOrigin {}) + = mkExpectedActualMsg ty1 ty2 orig + + + mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o) + = (Nothing, msg1 $$ msg2) where - ctxt2 = ctxt1 { cec_extra = msg $$ cec_extra ctxt1 } - msg = mkExpectedActualMsg exp act - mk_err ctxt1 _ = mkEqErr_help ctxt1 ct False ty1 ty2 + msg1 = hang (ptext (sLit "When matching types")) + 2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1) + , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ]) + msg2 = case sub_o of + TypeEqOrigin {} -> snd (mkExpectedActualMsg cty1 cty2 sub_o) + _ -> empty + + mk_wanted_extra _ = (Nothing, empty) mkEqErr_help, reportEqErr - :: ReportErrCtxt + :: ReportErrCtxt -> SDoc -> Ct - -> Bool -- True <=> Types are correct way round; - -- report "expected ty1, actual ty2" - -- False <=> Just report a mismatch without orientation - -- The ReportErrCtxt has expected/actual + -> Maybe SwapFlag -- Nothing <=> not sure -> TcType -> TcType -> TcM ErrMsg -mkEqErr_help ctxt ct oriented ty1 ty2 - | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt ct oriented tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt ct oriented tv2 ty1 - | otherwise = reportEqErr ctxt ct oriented ty1 ty2 +mkEqErr_help ctxt extra ct oriented ty1 ty2 + | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt extra ct oriented tv1 ty2 + | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt extra ct oriented tv2 ty1 + | otherwise = reportEqErr ctxt extra ct oriented ty1 ty2 -reportEqErr ctxt ct oriented ty1 ty2 - = do { ctxt' <- mkEqInfoMsg ctxt ct ty1 ty2 - ; mkErrorReport ctxt' (misMatchOrCND ctxt' ct oriented ty1 ty2) } +reportEqErr ctxt extra1 ct oriented ty1 ty2 + = do { (ctxt', extra2) <- mkEqInfoMsg ctxt ct ty1 ty2 + ; mkErrorMsg ctxt' ct (vcat [ misMatchOrCND ctxt' ct oriented ty1 ty2 + , extra2, extra1]) } -mkTyVarEqErr :: ReportErrCtxt -> Ct -> Bool -> TcTyVar -> TcType -> TcM ErrMsg +mkTyVarEqErr :: ReportErrCtxt -> SDoc -> Ct -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg -- tv1 and ty2 are already tidied -mkTyVarEqErr ctxt ct oriented tv1 ty2 - | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would - -- be oriented the other way round; see TcCanonical.reOrient +mkTyVarEqErr ctxt extra ct oriented tv1 ty2 + -- Occurs check + | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would + -- be oriented the other way round; see TcCanonical.reOrient || isSigTyVar tv1 && not (isTyVarTy ty2) - = mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) - (misMatchOrCND ctxt ct oriented ty1 ty2) + = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2 + , extraTyVarInfo ctxt ty1 ty2 + , extra ]) -- So tv is a meta tyvar, and presumably it is -- an *untouchable* meta tyvar, else it'd have been unified | not (k2 `tcIsSubKind` k1) -- Kind error - = mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) + = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra) - -- Occurs check | isNothing (occurCheckExpand tv1 ty2) = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2 - (sep [ppr ty1, char '=', ppr ty2]) - in mkErrorReport ctxt occCheckMsg + (sep [ppr ty1, char '~', ppr ty2]) + in mkErrorMsg ctxt ct (occCheckMsg $$ extra) -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context - , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) (ic_skols implic) - implic_loc = ic_loc implic + , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic + , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols , not (null esc_skols) - = setCtLoc implic_loc $ -- Override the error message location from the - -- place the equality arose to the implication site - do { (ctxt', env_sigs) <- findGlobals ctxt (unitVarSet tv1) - ; let msg = misMatchMsg oriented ty1 ty2 + = do { let msg = misMatchMsg oriented ty1 ty2 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols <+> pprQuotedList esc_skols , ptext (sLit "would escape") <+> if isSingleton esc_skols then ptext (sLit "its scope") else ptext (sLit "their scope") ] - extra1 = vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then ptext (sLit "This (rigid, skolem) type variable is") - else ptext (sLit "These (rigid, skolem) type variables are")) - <+> ptext (sLit "bound by") - , nest 2 $ ppr (ctLocOrigin implic_loc) ] ] - ; mkErrorReport ctxt' (msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) } + tv_extra = vcat [ nest 2 $ esc_doc + , sep [ (if isSingleton esc_skols + then ptext (sLit "This (rigid, skolem) type variable is") + else ptext (sLit "These (rigid, skolem) type variables are")) + <+> ptext (sLit "bound by") + , nest 2 $ ppr skol_info + , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ] + ; mkErrorMsg ctxt ct (msg $$ tv_extra $$ extra) } -- Nastiest case: attempt to unify an untouchable variable | (implic:_) <- cec_encl ctxt -- Get the innermost context - , let implic_loc = ic_loc implic - given = ic_given implic - = setCtLoc (ic_loc implic) $ - do { let msg = misMatchMsg oriented ty1 ty2 - extra = quotes (ppr tv1) - <+> sep [ ptext (sLit "is untouchable") - , ptext (sLit "inside the constraints") <+> pprEvVarTheta given - , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)] - ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } + , Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic + = do { let msg = misMatchMsg oriented ty1 ty2 + untch_extra + = nest 2 $ + sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable") + , nest 2 $ ptext (sLit "inside the constraints") <+> pprEvVarTheta given + , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info + , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] + tv_extra = extraTyVarInfo ctxt ty1 ty2 + ; mkErrorMsg ctxt ct (vcat [msg, untch_extra, tv_extra, extra]) } | otherwise - = reportEqErr ctxt ct oriented (mkTyVarTy tv1) ty2 + = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2 -- This *can* happen (Trac #6123, and test T2627b) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, becuase F is a type function. @@ -595,7 +649,7 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2 k2 = typeKind ty2 ty1 = mkTyVarTy tv1 -mkEqInfoMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> TcM ReportErrCtxt +mkEqInfoMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> TcM (ReportErrCtxt, SDoc) -- Report (a) ambiguity if either side is a type function application -- e.g. F a0 ~ Int -- (b) warning about injectivity if both sides are the same @@ -605,7 +659,7 @@ mkEqInfoMsg ctxt ct ty1 ty2 = do { (ctxt', _, ambig_msg) <- if isJust mb_fun1 || isJust mb_fun2 then mkAmbigMsg ctxt [ct] else return (ctxt, False, empty) - ; return (ctxt' { cec_extra = tyfun_msg $$ ambig_msg $$ cec_extra ctxt' }) } + ; return (ctxt', tyfun_msg $$ ambig_msg) } where mb_fun1 = isTyFun_maybe ty1 mb_fun2 = isTyFun_maybe ty2 @@ -616,12 +670,23 @@ mkEqInfoMsg ctxt ct ty1 ty2 <+> ptext (sLit "is a type function, and may not be injective") | otherwise = empty -misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc +isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool +-- See Note [Reporting occurs-check errors] +isUserSkolem ctxt tv + = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt) + where + is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info }) + = tv `elem` sks && is_user_skol_info skol_info + + is_user_skol_info (InferSkol {}) = False + is_user_skol_info _ = True + +misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc -- If oriented then ty1 is expected, ty2 is actual misMatchOrCND ctxt ct oriented ty1 ty2 | null givens || (isRigid ty1 && isRigid ty2) || - isGiven (cc_ev ct) + isGivenCt ct -- If the equality is unconditionally insoluble -- or there is no context, don't report the context = misMatchMsg oriented ty1 ty2 @@ -629,29 +694,30 @@ misMatchOrCND ctxt ct oriented ty1 ty2 = couldNotDeduce givens ([mkEqPred ty1 ty2], orig) where givens = getUserGivens ctxt - orig = TypeEqOrigin (UnifyOrigin ty1 ty2) + orig = TypeEqOrigin ty1 ty2 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc couldNotDeduce givens (wanteds, orig) = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds) , vcat (pp_givens givens)] -pp_givens :: [([EvVar], GivenLoc)] -> [SDoc] +pp_givens :: [UserGiven] -> [SDoc] pp_givens givens = case givens of [] -> [] (g:gs) -> ppr_given (ptext (sLit "from the context")) g : map (ppr_given (ptext (sLit "or from"))) gs - where ppr_given herald (gs,loc) + where + ppr_given herald (gs, skol_info, loc) = hang (herald <+> pprEvVarTheta gs) - 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc) - , ptext (sLit "at") <+> ppr (ctLocSpan loc)]) + 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info + , ptext (sLit "at") <+> ppr loc]) -addExtraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt +extraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> SDoc -- Add on extra info about the types themselves -- NB: The types themselves are already tidied -addExtraTyVarInfo ctxt ty1 ty2 - = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt } +extraTyVarInfo ctxt ty1 ty2 + = nest 2 (extra1 $$ extra2) where extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1 extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2 @@ -663,21 +729,13 @@ tyVarExtraInfoMsg implics ty , isTcTyVar tv, isSkolemTyVar tv , let pp_tv = quotes (ppr tv) = case tcTyVarDetails tv of - SkolemTv {} -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv) + SkolemTv {} -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv) FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") MetaTv {} -> empty | otherwise -- Normal case = empty - where - ppr_skol given_loc tv_loc - = case skol_info of - UnkSkol -> ptext (sLit "is an unknown type variable") - _ -> sep [ ptext (sLit "is a rigid type variable bound by"), - sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]] - where - skol_info = ctLocOrigin given_loc kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy kindErrorMsg ty1 ty2 @@ -689,10 +747,12 @@ kindErrorMsg ty1 ty2 k2 = typeKind ty2 -------------------- -misMatchMsg :: Bool -> TcType -> TcType -> SDoc -- Types are already tidy +misMatchMsg :: Maybe SwapFlag -> TcType -> TcType -> SDoc -- Types are already tidy -- If oriented then ty1 is expected, ty2 is actual -misMatchMsg oriented ty1 ty2 - | oriented +misMatchMsg oriented ty1 ty2 + | Just IsSwapped <- oriented + = misMatchMsg (Just NotSwapped) ty2 ty1 + | Just NotSwapped <- oriented = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty1) , nest 12 $ ptext (sLit "with actual") <+> what <+> quotes (ppr ty2) ] | otherwise @@ -702,12 +762,36 @@ misMatchMsg oriented ty1 ty2 what | isKind ty1 = ptext (sLit "kind") | otherwise = ptext (sLit "type") -mkExpectedActualMsg :: Type -> Type -> SDoc -mkExpectedActualMsg exp_ty act_ty - = vcat [ text "Expected type:" <+> ppr exp_ty - , text " Actual type:" <+> ppr act_ty ] +mkExpectedActualMsg :: Type -> Type -> CtOrigin -> (Maybe SwapFlag, SDoc) +mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp }) + | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just IsSwapped, empty) + | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just NotSwapped, empty) + | otherwise = (Nothing, msg) + where + msg = vcat [ text "Expected type:" <+> ppr exp + , text " Actual type:" <+> ppr act ] + +mkExpectedActualMsg _ _ _ = panic "mkExprectedAcutalMsg" \end{code} +Note [Reporting occurs-check errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied +type signature, then the best thing is to report that we can't unify +a with [a], because a is a skolem variable. That avoids the confusing +"occur-check" error message. + +But nowadays when inferring the type of a function with no type signature, +even if there are errors inside, we still generalise its signature and +carry on. For example + f x = x:x +Here we will infer somethiing like + f :: forall a. a -> [a] +with a suspended error of (a ~ [a]). So 'a' is now a skolem, but not +one bound by the programmer! Here we really should report an occurs check. + +So isUserSkolem distinguishes the two. + Note [Non-injective type functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's very confusing to get a message like @@ -739,8 +823,9 @@ mkDictErr ctxt cts -- have the same source-location origin, to try avoid a cascade -- of error from one location ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; mkErrorReport ctxt err } + ; mkErrorMsg ctxt ct1 err } where + ct1:_ = cts no_givens = null (getUserGivens ctxt) is_no_inst (ct, (matches, unifiers, _)) = no_givens @@ -755,13 +840,15 @@ mkDictErr ctxt cts (clas, tys) = getClassPredTys (ctPred ct) mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) - -> TcM (ReportErrCtxt, SDoc) + -> TcM (ReportErrCtxt, SDoc) -- Report an overlap error if this class constraint results -- from an overlap (returning Left clas), otherwise return (Right pred) mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) | null matches -- No matches but perhaps several unifiers - = do { (ctxt', is_ambig, ambig_msg) <- mkAmbigMsg ctxt [ct] - ; return (ctxt', cannot_resolve_msg is_ambig ambig_msg) } + = do { (ctxt, is_ambig, ambig_msg) <- mkAmbigMsg ctxt [ct] + ; (ctxt, binds_msg) <- relevantBindings ctxt ct + ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg) + ; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) } | not safe_haskell -- Some matches => overlap errors = return (ctxt, overlap_msg) @@ -769,22 +856,20 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) | otherwise = return (ctxt, safe_haskell_msg) where - orig = ctLocOrigin (ctWantedLoc ct) + orig = ctLocOrigin (cc_loc ct) pred = ctPred ct (clas, tys) = getClassPredTys pred ispecs = [ispec | (ispec, _) <- matches] givens = getUserGivens ctxt all_tyvars = all isTyVarTy tys - cannot_resolve_msg has_ambig_tvs ambig_msg + cannot_resolve_msg has_ambig_tvs binds_msg ambig_msg = vcat [ addArising orig (no_inst_herald <+> pprParendType pred) , vcat (pp_givens givens) - , if has_ambig_tvs && (not (null unifiers) || not (null givens)) - then ambig_msg $$ potential_msg + , if (has_ambig_tvs && not (null unifiers && null givens)) + then vcat [ ambig_msg, binds_msg, potential_msg ] else empty - , show_fixes (inst_decl_fixes - ++ add_to_ctxt_fixes has_ambig_tvs - ++ drv_fixes) ] + , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ] potential_msg | null unifiers = empty @@ -808,19 +893,14 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) ppr_skol skol_info = ppr skol_info -- Do not suggest adding constraints to an *inferred* type signature! - get_good_orig ic = case ctLocOrigin (ic_loc ic) of - SigSkol (InfSigCtxt {}) _ -> Nothing - origin -> Just origin + get_good_orig ic = case ic_info ic of + SigSkol (InfSigCtxt {}) _ -> Nothing + origin -> Just origin no_inst_herald | null givens && null matches = ptext (sLit "No instance for") | otherwise = ptext (sLit "Could not deduce") - inst_decl_fixes - | all_tyvars = [] - | otherwise = [ sep [ ptext (sLit "add an instance declaration for") - , pprParendType pred] ] - drv_fixes = case orig of DerivOrigin -> [drv_fix] _ -> [] @@ -869,12 +949,12 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) givens = getUserGivens ctxt matching_givens = mapCatMaybes matchable givens - matchable (evvars,gloc) + matchable (evvars,skol_info,loc) = case ev_vars_matching of [] -> Nothing _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc) - , ptext (sLit "at") <+> ppr (ctLocSpan gloc)]) + 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info + , ptext (sLit "at") <+> ppr loc]) where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) ev_var_matches ty = case getClassPredTys_maybe ty of Just (clas', tys') @@ -972,9 +1052,17 @@ mkAmbigMsg ctxt cts = return (ctxt, False, empty) | otherwise = do { dflags <- getDynFlags - ; (ctxt', gbl_docs) <- findGlobals ctxt ambig_tv_set - ; return (ctxt', True, mk_msg dflags gbl_docs) } + + ; prs <- mapSndM zonkTcType $ + [ (id, idType id) | TcIdBndr id top_lvl <- ct1_bndrs + , isTopLevel top_lvl ] + ; let ambig_ids = [id | (id, zonked_ty) <- prs + , tyVarsOfType zonked_ty `intersectsVarSet` ambig_tv_set] + ; return (ctxt, True, mk_msg dflags ambig_ids) } where + ct1:_ = cts + ct1_bndrs = tcl_bndrs (ctLocEnv (cc_loc ct1)) + ambig_tv_set = foldr (unionVarSet . filterVarSet isAmbiguousTyVar . tyVarsOfCt) emptyVarSet cts ambig_tvs = varSetElems ambig_tv_set @@ -982,7 +1070,7 @@ mkAmbigMsg ctxt cts is_or_are | isSingleton ambig_tvs = text "is" | otherwise = text "are" - mk_msg dflags docs + mk_msg dflags ambig_ids | any isRuntimeUnkSkol ambig_tvs -- See Note [Runtime skolems] = vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs <+> pprQuotedList ambig_tvs @@ -991,17 +1079,17 @@ mkAmbigMsg ctxt cts = vcat [ text "The type variable" <> plural ambig_tvs <+> pprQuotedList ambig_tvs <+> is_or_are <+> text "ambiguous" - , mk_extra_msg dflags docs ] + , mk_extra_msg dflags ambig_ids ] - mk_extra_msg dflags docs - | null docs + mk_extra_msg dflags ambig_ids + | null ambig_ids = ptext (sLit "Possible fix: add a type signature that fixes these type variable(s)") -- This happens in things like -- f x = show (read "foo") -- where monomorphism doesn't play any role | otherwise - = vcat [ ptext (sLit "Possible cause: the monomorphism restriction applied to the following:") - , nest 2 (vcat docs) + = vcat [ hang (ptext (sLit "Possible cause: the monomorphism restriction applied to:")) + 2 (pprWithCommas (quotes . ppr) ambig_ids) , ptext (sLit "Probable fix:") <+> vcat [ ptext (sLit "give these definition(s) an explicit type signature") , if xopt Opt_MonomorphismRestriction dflags @@ -1010,89 +1098,80 @@ mkAmbigMsg ctxt cts -- if it is not already set! ] -getSkolemInfo :: [Implication] -> TcTyVar -> GivenLoc + +pprSkol :: SkolemInfo -> SrcLoc -> SDoc +pprSkol UnkSkol _ + = ptext (sLit "is an unknown type variable") +pprSkol skol_info tv_loc + = sep [ ptext (sLit "is a rigid type variable bound by"), + sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]] + +getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo -- Get the skolem info for a type variable -- from the implication constraint that binds it getSkolemInfo [] tv - = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv ) - CtLoc UnkSkol noSrcSpan [] + = pprPanic "No skolem info:" (ppr tv) getSkolemInfo (implic:implics) tv - | tv `elem` ic_skols implic = ic_loc implic + | tv `elem` ic_skols implic = ic_info implic | otherwise = getSkolemInfo implics tv ----------------------- --- findGlobals looks at the value environment and finds values whose +-- relevantBindings looks at the value environment and finds values whose -- types mention any of the offending type variables. It has to be -- careful to zonk the Id's type first, so it has to be in the monad. -- We must be careful to pass it a zonked type variable, too. -mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc -mkEnvSigMsg what env_sigs - | null env_sigs = empty - | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what - , nest 2 (vcat env_sigs) ] - -findGlobals :: ReportErrCtxt - -> TcTyVarSet - -> TcM (ReportErrCtxt, [SDoc]) - -findGlobals ctxt tvs - = do { lcl_ty_env <- case cec_encl ctxt of - [] -> getLclTypeEnv - (i:_) -> return (ic_env i) - ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) } +relevantBindings :: ReportErrCtxt -> Ct + -> TcM (ReportErrCtxt, SDoc) +relevantBindings ctxt ct + = do { (tidy_env', docs) <- go (cec_tidy ctxt) (6, emptyVarSet) + (reverse (tcl_bndrs lcl_env)) + -- The 'reverse' makes us work from outside in + -- Blargh; maybe have a flag for this "6" + + ; traceTc "relevantBindings" (ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env]) + ; let doc = hang (ptext (sLit "Relevant bindings include")) + 2 (vcat docs) + ; if null docs + then return (ctxt, empty) + else do { traceTc "rb" doc + ; return (ctxt { cec_tidy = tidy_env' }, doc) } } where - go tidy_env acc [] = return (ctxt { cec_tidy = tidy_env }, acc) - go tidy_env acc (thing : things) - = do { (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing - ; case maybe_doc of - Just d -> go tidy_env1 (d:acc) things - Nothing -> go tidy_env1 acc things } - - ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty + lcl_env = ctLocEnv (cc_loc ct) + ct_tvs = tyVarsOfCt ct + + go :: TidyEnv -> (Int, TcTyVarSet) + -> [TcIdBinder] -> TcM (TidyEnv, [SDoc]) + go tidy_env (_,_) [] + = return (tidy_env, []) + go tidy_env (n_left,tvs_seen) (TcIdBndr id _ : tc_bndrs) + | n_left <= 0, ct_tvs `subVarSet` tvs_seen + = -- We have run out of n_left, and we + -- already have bindings mentioning all of ct_tvs + go tidy_env (n_left,tvs_seen) tc_bndrs + | otherwise + = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) + ; let id_tvs = tyVarsOfType tidy_ty + doc = sep [ ppr id <+> dcolon <+> ppr tidy_ty + , nest 2 (parens (ptext (sLit "bound at") + <+> ppr (getSrcLoc id)))] + ; if id_tvs `intersectsVarSet` ct_tvs + && (n_left > 0 || not (id_tvs `subVarSet` tvs_seen)) + -- Either we n_left is big enough, + -- or this binding mentions a new type variable + then do { (env', docs) <- go tidy_env' (n_left - 1, tvs_seen `unionVarSet` id_tvs) tc_bndrs + ; return (env', doc:docs) } + else go tidy_env (n_left, tvs_seen) tc_bndrs } ----------------------- -find_thing :: TidyEnv -> (TcType -> Bool) - -> TcTyThing -> TcM (TidyEnv, Maybe SDoc) -find_thing tidy_env ignore_it (ATcId { tct_id = id }) - = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) - ; if ignore_it tidy_ty then - return (tidy_env, Nothing) - else do - { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (ptext (sLit "bound at") <+> - ppr (getSrcLoc id)))] - ; return (tidy_env', Just msg) } } - -find_thing tidy_env ignore_it (ATyVar name tv) - = do { ty <- zonkTcTyVar tv - ; let (tidy_env1, tidy_ty) = tidyOpenType tidy_env ty - ; if ignore_it tidy_ty then - return (tidy_env, Nothing) - else do - { let -- The name tv is scoped, so we don't need to tidy it - msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr name) <+> eq_stuff - , nest 2 bound_at] - - eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty - , getOccName name == getOccName tv' = empty - | otherwise = equals <+> ppr tidy_ty - -- It's ok to use Type.getTyVar_maybe because ty is zonked by now - bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc name) - - ; return (tidy_env1, Just msg) } } - -find_thing _ _ thing = pprPanic "find_thing" (ppr thing) - -warnDefaulting :: [Ct] -> Type -> TcM () +warnDefaulting :: Cts -> Type -> TcM () warnDefaulting wanteds default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv - ; let wanted_bag = listToBag wanteds - tidy_env = tidyFreeTyVars env0 $ - tyVarsOfCts wanted_bag - tidy_wanteds = mapBag (tidyCt tidy_env) wanted_bag + ; let tidy_env = tidyFreeTyVars env0 $ + tyVarsOfCts wanteds + tidy_wanteds = mapBag (tidyCt tidy_env) wanteds (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds) warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty)) @@ -1114,58 +1193,19 @@ are created by in RtClosureInspect.zonkRTTIType. %************************************************************************ \begin{code} -solverDepthErrorTcS :: Int -> [Ct] -> TcM a -solverDepthErrorTcS depth stack - | null stack -- Shouldn't happen unless you say -fcontext-stack=0 - = failWith msg - | otherwise - = setCtFlavorLoc (cc_ev top_item) $ - do { zstack <- mapM zonkCt stack - ; env0 <- tcInitTidyEnv - ; let zstack_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet zstack - tidy_env = tidyFreeTyVars env0 zstack_tvs - tidy_cts = map (tidyCt tidy_env) zstack - ; failWithTcM (tidy_env, hang msg 2 (vcat (map (ppr . ctPred) tidy_cts))) } - where - top_item = head stack - msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth - , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] - -{- DV: Changing this because Derived's no longer have ids ... Kind of a corner case ... - = setCtFlavorLoc (cc_ev top_item) $ - do { ev_vars <- mapM (zonkEvVar . cc_id) stack +solverDepthErrorTcS :: Ct -> TcM a +solverDepthErrorTcS ct + = setCtLoc loc $ + do { pred <- zonkTcType (ctPred ct) ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars) - tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars - ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) } + ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfType pred) + tidy_pred = tidyType tidy_env pred + ; failWithTcM (tidy_env, hang msg 2 (ppr tidy_pred)) } where - top_item = head stack + loc = cc_loc ct + depth = ctLocDepth loc msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] --} - - -flattenForAllErrorTcS :: CtEvidence -> TcType -> TcM a -flattenForAllErrorTcS fl ty - = setCtFlavorLoc fl $ - do { env0 <- tcInitTidyEnv - ; let (env1, ty') = tidyOpenType env0 ty - msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:") - , ppr ty' ] - ; failWithTcM (env1, msg) } -\end{code} - -%************************************************************************ -%* * - Setting the context -%* * -%************************************************************************ - -\begin{code} -setCtFlavorLoc :: CtEvidence -> TcM a -> TcM a -setCtFlavorLoc (Wanted { ctev_wloc = loc }) thing = setCtLoc loc thing -setCtFlavorLoc (Derived { ctev_wloc = loc }) thing = setCtLoc loc thing -setCtFlavorLoc (Given { ctev_gloc = loc }) thing = setCtLoc loc thing \end{code} %************************************************************************ @@ -1180,10 +1220,19 @@ zonkTidyTcType env ty = do { ty' <- zonkTcType ty ; return (tidyOpenType env ty') } zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM (ReportErrCtxt, CtOrigin) -zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) - = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act +zonkTidyOrigin ctxt (GivenOrigin skol_info) + = do { skol_info1 <- zonkSkolemInfo skol_info + ; let (env1, skol_info2) = tidySkolemInfo (cec_tidy ctxt) skol_info1 + ; return (ctxt { cec_tidy = env1 }, GivenOrigin skol_info2) } +zonkTidyOrigin ctxt (TypeEqOrigin { uo_actual = act, uo_expected = exp }) + = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act ; (env2, exp') <- zonkTidyTcType env1 exp ; return ( ctxt { cec_tidy = env2 } - , TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) } + , TypeEqOrigin { uo_actual = act', uo_expected = exp' }) } +zonkTidyOrigin ctxt (KindEqOrigin ty1 ty2 orig) + = do { (env1, ty1') <- zonkTidyTcType (cec_tidy ctxt) ty1 + ; (env2, ty2') <- zonkTidyTcType env1 ty2 + ; (ctxt2, orig') <- zonkTidyOrigin (ctxt { cec_tidy = env2 }) orig + ; return (ctxt2, KindEqOrigin ty1' ty2' orig') } zonkTidyOrigin ctxt orig = return (ctxt, orig) \end{code} diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 321809f91d..b160c3282c 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -16,14 +16,14 @@ module TcEvidence ( EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, - EvTerm(..), mkEvCast, evVarsOfTerm, mkEvKindCast, + EvTerm(..), mkEvCast, evVarsOfTerm, EvLit(..), evTermCoercion, -- TcCoercion - TcCoercion(..), + TcCoercion(..), LeftOrRight(..), pickLR, mkTcReflCo, mkTcTyConAppCo, mkTcAppCo, mkTcAppCos, mkTcFunCo, mkTcAxInstCo, mkTcForAllCo, mkTcForAllCos, - mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcInstCos, + mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcInstCos, tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo, isTcReflCo, isTcReflCo_maybe, getTcCoVar_maybe, liftTcCoSubstWith @@ -32,7 +32,7 @@ module TcEvidence ( #include "HsVersions.h" import Var - +import Coercion( LeftOrRight(..), pickLR ) import PprCore () -- Instance OutputableBndr TyVar import TypeRep -- Knows type representation import TcType @@ -102,6 +102,7 @@ data TcCoercion | TcSymCo TcCoercion | TcTransCo TcCoercion TcCoercion | TcNthCo Int TcCoercion + | TcLRCo LeftOrRight TcCoercion | TcCastCo TcCoercion TcCoercion -- co1 |> co2 | TcLetCo TcEvBinds TcCoercion deriving (Data.Data, Data.Typeable) @@ -167,6 +168,10 @@ mkTcNthCo :: Int -> TcCoercion -> TcCoercion mkTcNthCo n (TcRefl ty) = TcRefl (tyConAppArgN n ty) mkTcNthCo n co = TcNthCo n co +mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion +mkTcLRCo lr (TcRefl ty) = TcRefl (pickLR lr (tcSplitAppTy ty)) +mkTcLRCo lr co = TcLRCo lr co + mkTcAppCos :: TcCoercion -> [TcCoercion] -> TcCoercion mkTcAppCos co1 tys = foldl mkTcAppCo co1 tys @@ -211,6 +216,7 @@ tcCoercionKind co = go co go (TcSymCo co) = swap (go co) go (TcTransCo co1 co2) = Pair (pFst (go co1)) (pSnd (go co2)) go (TcNthCo d co) = tyConAppArgN d <$> go co + go (TcLRCo lr co) = (pickLR lr . tcSplitAppTy) <$> go co -- c.f. Coercion.coercionKind go_inst (TcInstCo co ty) tys = go_inst co (ty:tys) @@ -239,6 +245,7 @@ coVarsOfTcCo tc_co go (TcSymCo co) = go co go (TcTransCo co1 co2) = go co1 `unionVarSet` go co2 go (TcNthCo _ co) = go co + go (TcLRCo _ co) = go co go (TcLetCo (EvBinds bs) co) = foldrBag (unionVarSet . go_bind) (go co) bs `minusVarSet` get_bndrs bs go (TcLetCo {}) = emptyVarSet -- Harumph. This does legitimately happen in the call @@ -306,6 +313,7 @@ ppr_co p (TcTransCo co1 co2) = maybeParen p FunPrec $ <+> ppr_co FunPrec co2 ppr_co p (TcSymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendTcCo co] ppr_co p (TcNthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendTcCo co] +ppr_co p (TcLRCo lr co) = pprPrefixApp p (ppr lr) [pprParendTcCo co] ppr_fun_co :: Prec -> TcCoercion -> SDoc ppr_fun_co p co = pprArrowChain p (split co) @@ -475,8 +483,6 @@ data EvTerm -- dictionaries, even though the former have no -- selector Id. We count up from _0_ - | EvKindCast EvTerm TcCoercion -- See Note [EvKindCast] - | EvLit EvLit -- Dictionary for class "SingI" for type lits. -- Note [EvLit] @@ -502,29 +508,17 @@ We do quite often need to get a TcCoercion from an EvTerm; see INVARIANT: The evidence for any constraint with type (t1~t2) is a coercion evidence term. Consider for example - [G] g :: F Int a + [G] d :: F Int a If we have ax7 a :: F Int a ~ (a ~ Bool) then we do NOT generate the constraint - [G} (g |> ax7 a) :: a ~ Bool -because that does not satisfy the invariant. Instead we make a binding + [G} (d |> ax7 a) :: a ~ Bool +because that does not satisfy the invariant (d is not a coercion variable). +Instead we make a binding g1 :: a~Bool = g |> ax7 a and the constraint [G] g1 :: a~Bool -See Trac [7238] - -Note [EvKindCast] -~~~~~~~~~~~~~~~~~ -EvKindCast g kco is produced when we have a constraint (g : s1 ~ s2) -but the kinds of s1 and s2 (k1 and k2 respectively) don't match but -are rather equal by a coercion. You may think that this coercion will -always turn out to be ReflCo, so why is this needed? Because sometimes -we will want to defer kind errors until the runtime and in these cases -that coercion will be an 'error' term, which we want to evaluate rather -than silently forget about! - -The relevant (and only) place where such a coercion is produced in -the simplifier is in TcCanonical.emitKindConstraint. +See Trac [7238] and Note [Bind new Givens immediately] in TcSMonad Note [EvBinds/EvTerm] ~~~~~~~~~~~~~~~~~~~~~ @@ -587,11 +581,6 @@ mkEvCast ev lco | isTcReflCo lco = ev | otherwise = EvCast ev lco -mkEvKindCast :: EvTerm -> TcCoercion -> EvTerm -mkEvKindCast ev lco - | isTcReflCo lco = ev - | otherwise = EvKindCast ev lco - emptyTcEvBinds :: TcEvBinds emptyTcEvBinds = EvBinds emptyBag @@ -617,7 +606,6 @@ evVarsOfTerm (EvSuperClass v _) = evVarsOfTerm v evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co evVarsOfTerm (EvTupleMk evs) = evVarsOfTerms evs evVarsOfTerm (EvDelayedError _ _) = emptyVarSet -evVarsOfTerm (EvKindCast v co) = coVarsOfTcCo co `unionVarSet` evVarsOfTerm v evVarsOfTerm (EvLit _) = emptyVarSet evVarsOfTerms :: [EvTerm] -> VarSet @@ -675,7 +663,6 @@ instance Outputable EvBind where instance Outputable EvTerm where ppr (EvId v) = ppr v ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co - ppr (EvKindCast v co) = ppr v <+> (ptext (sLit "`kind-cast`")) <+> pprParendTcCo co ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n)) ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 51b5eb3fa7..e21eb4e4da 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -231,6 +231,15 @@ tcExpr (HsType ty) _ -- so it's not enabled yet. -- Can't eliminate it altogether from the parser, because the -- same parser parses *patterns*. +tcExpr HsHole res_ty + = do { ty <- newFlexiTyVarTy liftedTypeKind + ; traceTc "tcExpr.HsHole" (ppr ty) + ; ev <- mkSysLocalM (mkFastString "_") ty + ; loc <- getCtLoc HoleOrigin + ; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_loc = loc } + ; traceTc "tcExpr.HsHole emitting" (ppr can) + ; emitInsoluble can + ; tcWrapResult (HsVar ev) ty res_ty } \end{code} @@ -304,20 +313,28 @@ tcExpr (OpApp arg1 op fix arg2) res_ty ; let doc = ptext (sLit "The first argument of ($) takes") ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty - -- arg2_ty maybe polymorphic; that's the point + -- arg1_ty = arg2_ty -> op_res_ty + -- And arg2_ty maybe polymorphic; that's the point -- Make sure that the argument and result types have kind '*' -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 - ; _ <- unifyKind (typeKind arg2_ty) liftedTypeKind - ; _ <- unifyKind (typeKind res_ty) liftedTypeKind + -- ($) :: forall ab. (a->b) -> a -> b + ; a_ty <- newFlexiTyVarTy liftedTypeKind + ; b_ty <- newFlexiTyVarTy liftedTypeKind ; arg2' <- tcArg op (arg2, arg2_ty, 2) - ; co_res <- unifyType op_res_ty res_ty - ; op_id <- tcLookupId op_name - ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id)) - ; return $ mkHsWrapCo co_res $ - OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' } + ; co_res <- unifyType b_ty res_ty -- b ~ res + ; co_a <- unifyType arg2_ty a_ty -- arg2 ~ a + ; co_b <- unifyType op_res_ty b_ty -- op_res ~ b + ; op_id <- tcLookupId op_name + + ; let op' = L loc (HsWrap (mkWpTyApps [a_ty, b_ty]) (HsVar op_id)) + ; return $ mkHsWrapCo (co_res) $ + OpApp (mkLHsWrapCo (mkTcFunCo co_a co_b) $ + mkLHsWrapCo co_arg1 arg1') + op' fix + (mkLHsWrapCo co_a arg2') } | otherwise = do { traceTc "Non Application rule" (ppr op) @@ -456,14 +473,6 @@ tcExpr (HsDo do_or_lc stmts _) res_ty tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty ; return $ mkHsWrapCo coi (HsProc pat' cmd') } - -tcExpr e@(HsArrApp _ _ _ _ _) _ - = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), - ptext (sLit "was found where an expression was expected")]) - -tcExpr e@(HsArrForm _ _ _) _ - = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), - ptext (sLit "was found where an expression was expected")]) \end{code} Note [Rebindable syntax for if] @@ -830,6 +839,7 @@ tcExpr e@(HsQuasiQuoteE _) _ = \begin{code} tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) + -- Include ArrForm, ArrApp, which shouldn't appear at all \end{code} diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index e5baaeca9f..0b3dfaee38 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -391,7 +391,7 @@ gen_Ord_binds loc tycon ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)]) - mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName + mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName) -- Make the alternative (Ki a1 a2 .. av -> mkOrdOpAlt op data_con = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con) @@ -436,7 +436,7 @@ gen_Ord_binds loc tycon tag = get_tag data_con tag_lit = noLoc (HsLit (HsIntPrim (toInteger tag))) - mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName + mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName) -- First argument 'a' known to be built with K -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) mkInnerEqAlt op data_con @@ -1604,7 +1604,8 @@ mkSimpleLam2 lam = do return (mkHsLam [nlVarPat n1,nlVarPat n2] body) -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" -mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName) +mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] + -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName (LHsExpr RdrName)) mkSimpleConMatch fold extra_pats con insides = do let con_name = getRdrName con let vars_needed = takeList insides as_RDRs @@ -1613,7 +1614,8 @@ mkSimpleConMatch fold extra_pats con insides = do return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" -mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)) +mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] + -> m (LMatch RdrName (LHsExpr RdrName))) -> TupleSort -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName) mkSimpleTupleCase match_for_con sort insides x = do let con = tupleCon sort (length insides) @@ -1863,7 +1865,7 @@ mk_FunBind loc fun pats_and_exprs where matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] -mkRdrFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName +mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName mkRdrFunBind fun@(L _ fun_rdr) matches | null matches = mkFunBind fun [mkMatch [] (error_Expr str) emptyLocalBinds] -- Catch-all eqn looks like diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 84907fb306..92d2a5c96e 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -429,7 +429,7 @@ zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id) zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) = do { (_env, new_pat) <- zonkPat env pat -- Env already extended ; sig_warn False (collectPatBinders new_pat) - ; new_grhss <- zonkGRHSs env grhss + ; new_grhss <- zonkGRHSs env zonkLExpr grhss ; new_ty <- zonkTcTypeToType env ty ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } @@ -444,7 +444,7 @@ zonk_bind env sig_warn bind@(FunBind { fun_id = L loc var, fun_matches = ms = do { new_var <- zonkIdBndr env var ; sig_warn False [new_var] ; (env1, new_co_fn) <- zonkCoFn env co_fn - ; new_ms <- zonkMatchGroup env1 ms + ; new_ms <- zonkMatchGroup env1 zonkLExpr ms ; return (bind { fun_id = L loc new_var, fun_matches = new_ms , fun_co_fn = new_co_fn }) } @@ -495,28 +495,34 @@ zonkLTcSpecPrags env ps %************************************************************************ \begin{code} -zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id) -zonkMatchGroup env (MatchGroup ms ty) - = do { ms' <- mapM (zonkMatch env) ms +zonkMatchGroup :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id))) +zonkMatchGroup env zBody (MatchGroup ms ty) + = do { ms' <- mapM (zonkMatch env zBody) ms ; ty' <- zonkTcTypeToType env ty ; return (MatchGroup ms' ty') } -zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id) -zonkMatch env (L loc (Match pats _ grhss)) +zonkMatch :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id))) +zonkMatch env zBody (L loc (Match pats _ grhss)) = do { (env1, new_pats) <- zonkPats env pats - ; new_grhss <- zonkGRHSs env1 grhss + ; new_grhss <- zonkGRHSs env1 zBody grhss ; return (L loc (Match new_pats Nothing new_grhss)) } ------------------------------------------------------------------------- -zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id) +zonkGRHSs :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id))) -zonkGRHSs env (GRHSs grhss binds) +zonkGRHSs env zBody (GRHSs grhss binds) = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> let - zonk_grhs (GRHS guarded rhs) - = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) -> - zonkLExpr env2 rhs `thenM` \ new_rhs -> - returnM (GRHS new_guarded new_rhs) + zonk_grhs (GRHS guarded rhs) + = zonkStmts new_env zonkLExpr guarded `thenM` \ (env2, new_guarded) -> + zBody env2 rhs `thenM` \ new_rhs -> + returnM (GRHS new_guarded new_rhs) in mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss -> returnM (GRHSs new_grhss new_binds) @@ -554,12 +560,12 @@ zonkExpr env (HsOverLit lit) ; return (HsOverLit lit') } zonkExpr env (HsLam matches) - = zonkMatchGroup env matches `thenM` \ new_matches -> + = zonkMatchGroup env zonkLExpr matches `thenM` \ new_matches -> returnM (HsLam new_matches) zonkExpr env (HsLamCase arg matches) - = zonkTcTypeToType env arg `thenM` \ new_arg -> - zonkMatchGroup env matches `thenM` \ new_matches -> + = zonkTcTypeToType env arg `thenM` \ new_arg -> + zonkMatchGroup env zonkLExpr matches `thenM` \ new_matches -> returnM (HsLamCase new_arg new_matches) zonkExpr env (HsApp e1 e2) @@ -610,8 +616,8 @@ zonkExpr env (ExplicitTuple tup_args boxed) zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') } zonkExpr env (HsCase expr ms) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkMatchGroup env ms `thenM` \ new_ms -> + = zonkLExpr env expr `thenM` \ new_expr -> + zonkMatchGroup env zonkLExpr ms `thenM` \ new_ms -> returnM (HsCase new_expr new_ms) zonkExpr env (HsIf e0 e1 e2 e3) @@ -626,7 +632,7 @@ zonkExpr env (HsMultiIf ty alts) ; ty' <- zonkTcTypeToType env ty ; returnM $ HsMultiIf ty' alts' } where zonk_alt (GRHS guard expr) - = do { (env', guard') <- zonkStmts env guard + = do { (env', guard') <- zonkStmts env zonkLExpr guard ; expr' <- zonkLExpr env' expr ; returnM $ GRHS guard' expr' } @@ -636,8 +642,8 @@ zonkExpr env (HsLet binds expr) returnM (HsLet new_binds new_expr) zonkExpr env (HsDo do_or_lc stmts ty) - = zonkStmts env stmts `thenM` \ (_, new_stmts) -> - zonkTcTypeToType env ty `thenM` \ new_ty -> + = zonkStmts env zonkLExpr stmts `thenM` \ (_, new_stmts) -> + zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (HsDo do_or_lc new_stmts new_ty) zonkExpr env (ExplicitList ty exprs) @@ -697,30 +703,79 @@ zonkExpr env (HsProc pat body) ; new_body <- zonkCmdTop env1 body ; return (HsProc new_pat new_body) } -zonkExpr env (HsArrApp e1 e2 ty ho rl) - = zonkLExpr env e1 `thenM` \ new_e1 -> - zonkLExpr env e2 `thenM` \ new_e2 -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsArrApp new_e1 new_e2 new_ty ho rl) - -zonkExpr env (HsArrForm op fixity args) - = zonkLExpr env op `thenM` \ new_op -> - mappM (zonkCmdTop env) args `thenM` \ new_args -> - returnM (HsArrForm new_op fixity new_args) - zonkExpr env (HsWrap co_fn expr) = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) -> zonkExpr env1 expr `thenM` \ new_expr -> return (HsWrap new_co_fn new_expr) +zonkExpr _ HsHole + = return HsHole + zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) +------------------------------------------------------------------------- + +zonkLCmd :: ZonkEnv -> LHsCmd TcId -> TcM (LHsCmd Id) +zonkCmd :: ZonkEnv -> HsCmd TcId -> TcM (HsCmd Id) + +zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd + +zonkCmd env (HsCmdArrApp e1 e2 ty ho rl) + = zonkLExpr env e1 `thenM` \ new_e1 -> + zonkLExpr env e2 `thenM` \ new_e2 -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + returnM (HsCmdArrApp new_e1 new_e2 new_ty ho rl) + +zonkCmd env (HsCmdArrForm op fixity args) + = zonkLExpr env op `thenM` \ new_op -> + mappM (zonkCmdTop env) args `thenM` \ new_args -> + returnM (HsCmdArrForm new_op fixity new_args) + +zonkCmd env (HsCmdApp c e) + = zonkLCmd env c `thenM` \ new_c -> + zonkLExpr env e `thenM` \ new_e -> + returnM (HsCmdApp new_c new_e) + +zonkCmd env (HsCmdLam matches) + = zonkMatchGroup env zonkLCmd matches `thenM` \ new_matches -> + returnM (HsCmdLam new_matches) + +zonkCmd env (HsCmdPar c) + = zonkLCmd env c `thenM` \new_c -> + returnM (HsCmdPar new_c) + +zonkCmd env (HsCmdCase expr ms) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkMatchGroup env zonkLCmd ms `thenM` \ new_ms -> + returnM (HsCmdCase new_expr new_ms) + +zonkCmd env (HsCmdIf eCond ePred cThen cElse) + = do { new_eCond <- fmapMaybeM (zonkExpr env) eCond + ; new_ePred <- zonkLExpr env ePred + ; new_cThen <- zonkLCmd env cThen + ; new_cElse <- zonkLCmd env cElse + ; returnM (HsCmdIf new_eCond new_ePred new_cThen new_cElse) } + +zonkCmd env (HsCmdLet binds cmd) + = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> + zonkLCmd new_env cmd `thenM` \ new_cmd -> + returnM (HsCmdLet new_binds new_cmd) + +zonkCmd env (HsCmdDo stmts ty) + = zonkStmts env zonkLCmd stmts `thenM` \ (_, new_stmts) -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + returnM (HsCmdDo new_stmts new_ty) + + + + + zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id) zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id) zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) - = zonkLExpr env cmd `thenM` \ new_cmd -> + = zonkLCmd env cmd `thenM` \ new_cmd -> zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys -> zonkTcTypeToType env ty `thenM` \ new_ty -> mapSndM (zonkExpr env) ids `thenM` \ new_ids -> @@ -778,14 +833,18 @@ zonkArithSeq env (FromThenTo e1 e2 e3) ------------------------------------------------------------------------- -zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id]) -zonkStmts env [] = return (env, []) -zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s - ; (env2, ss') <- zonkStmts env1 ss - ; return (env2, s' : ss') } - -zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id) -zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op) +zonkStmts :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))]) +zonkStmts env _ [] = return (env, []) +zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s + ; (env2, ss') <- zonkStmts env1 zBody ss + ; return (env2, s' : ss') } + +zonkStmt :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id))) +zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op) = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs] env1 = extendIdZonkEnv env new_binders @@ -794,14 +853,14 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op) ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) } where zonk_branch (ParStmtBlock stmts bndrs return_op) - = do { (env1, new_stmts) <- zonkStmts env stmts + = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts ; new_return <- zonkExpr env1 return_op ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) } -zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs - , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id - , recS_later_rets = later_rets, recS_rec_rets = rec_rets - , recS_ret_ty = ret_ty }) +zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs + , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id + , recS_later_rets = later_rets, recS_rec_rets = rec_rets + , recS_ret_ty = ret_ty }) = do { new_rvs <- zonkIdBndrs env rvs ; new_lvs <- zonkIdBndrs env lvs ; new_ret_ty <- zonkTcTypeToType env ret_ty @@ -809,7 +868,7 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id ; new_mfix_id <- zonkExpr env mfix_id ; new_bind_id <- zonkExpr env bind_id ; let env1 = extendIdZonkEnv env new_rvs - ; (env2, new_segStmts) <- zonkStmts env1 segStmts + ; (env2, new_segStmts) <- zonkStmts env1 zBody segStmts -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt ; new_later_rets <- mapM (zonkExpr env2) later_rets @@ -821,22 +880,22 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id , recS_later_rets = new_later_rets , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) } -zonkStmt env (ExprStmt expr then_op guard_op ty) - = zonkLExpr env expr `thenM` \ new_expr -> +zonkStmt env zBody (BodyStmt body then_op guard_op ty) + = zBody env body `thenM` \ new_body -> zonkExpr env then_op `thenM` \ new_then -> zonkExpr env guard_op `thenM` \ new_guard -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (env, ExprStmt new_expr new_then new_guard new_ty) + returnM (env, BodyStmt new_body new_then new_guard new_ty) -zonkStmt env (LastStmt expr ret_op) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkExpr env ret_op `thenM` \ new_ret -> - returnM (env, LastStmt new_expr new_ret) +zonkStmt env zBody (LastStmt body ret_op) + = zBody env body `thenM` \ new_body -> + zonkExpr env ret_op `thenM` \ new_ret -> + returnM (env, LastStmt new_body new_ret) -zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap - , trS_by = by, trS_form = form, trS_using = using - , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) - = do { (env', stmts') <- zonkStmts env stmts +zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) + = do { (env', stmts') <- zonkStmts env zonkLExpr stmts ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap ; by' <- fmapMaybeM (zonkLExpr env') by ; using' <- zonkLExpr env using @@ -853,16 +912,16 @@ zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') -zonkStmt env (LetStmt binds) +zonkStmt env _ (LetStmt binds) = zonkLocalBinds env binds `thenM` \ (env1, new_binds) -> returnM (env1, LetStmt new_binds) -zonkStmt env (BindStmt pat expr bind_op fail_op) - = do { new_expr <- zonkLExpr env expr +zonkStmt env zBody (BindStmt pat body bind_op fail_op) + = do { new_body <- zBody env body ; (env1, new_pat) <- zonkPat env pat ; new_bind <- zonkExpr env bind_op ; new_fail <- zonkExpr env fail_op - ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } + ; return (env1, BindStmt new_pat new_body new_bind new_fail) } ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) @@ -1114,11 +1173,6 @@ zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcLCoToLCo env co zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm ; co' <- zonkTcLCoToLCo env co ; return (mkEvCast tm' co') } - -zonkEvTerm env (EvKindCast v co) = do { v' <- zonkEvTerm env v - ; co' <- zonkTcLCoToLCo env co - ; return (mkEvKindCast v' co') } - zonkEvTerm env (EvTupleSel tm n) = do { tm' <- zonkEvTerm env tm ; return (EvTupleSel tm' n) } zonkEvTerm env (EvTupleMk tms) = do { tms' <- mapM (zonkEvTerm env) tms @@ -1158,29 +1212,17 @@ zonkEvBinds env binds zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind zonkEvBind env (EvBind var term) - = case term of - -- Special-case fast paths for small coercions - -- NB: could be optimized further! (e.g. SymCo cv) - -- See Note [Optimized Evidence Binding Zonking] - EvCoercion co - | Just ty <- isTcReflCo_maybe co - -> do { zty <- zonkTcTypeToType env ty - ; let var' = setVarType var (mkEqPred zty zty) - -- Here we save the task of zonking var's type, - -- because we know just what it is! - ; return (EvBind var' (EvCoercion (mkTcReflCo zty))) } - - | Just cv <- getTcCoVar_maybe co - -> do { let cv' = zonkIdOcc env cv -- Just lazily look up - term' = EvCoercion (TcCoVarCo cv') - var' = setVarType var (varType cv') - ; return (EvBind var' term') } - - -- The default path - _ -> do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var - ; term' <- zonkEvTerm env term - ; return (EvBind var' term') - } + = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var + + -- Optimise the common case of Refl coercions + -- See Note [Optimise coercion zonking] + -- This has a very big effect on some programs (eg Trac #5030) + ; let ty' = idType var' + ; case getEqPredTys_maybe ty' of + Just (ty1, ty2) | ty1 `eqType` ty2 + -> return (EvBind var' (EvCoercion (mkTcReflCo ty1))) + _other -> do { term' <- zonkEvTerm env term + ; return (EvBind var' term') } } \end{code} %************************************************************************ @@ -1235,8 +1277,8 @@ The type of Phantom is (forall (k : BOX). forall (a : k). Int). Both `a` and we have a type or a kind variable; for kind variables we just return AnyK (and not the ill-kinded Any BOX). -Note [Optimized Evidence Binding Zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Optimise coercion zonkind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When optimising evidence binds we may come across situations where a coercion looks like cv = ReflCo ty @@ -1244,10 +1286,11 @@ or cv1 = cv2 where the type 'ty' is big. In such cases it is a waste of time to zonk both * The variable on the LHS * The coercion on the RHS -Rather, we can zonk the coercion, take its type and use that for -the variable. For big coercions this might be a lose, though, so we -just have a fast case for a couple of special cases. +Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just +use Refl on the right, ignoring the actual coercion on the RHS. +This can have a very big effect, because the constraint solver sometimes does go +to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf Trac #5030) \begin{code} zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType @@ -1257,16 +1300,17 @@ zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv SkolemTv {} -> lookup_in_env RuntimeUnk {} -> lookup_in_env FlatSkol ty -> zonkTcTypeToType env ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> do { kind <- {-# SCC "zonkKind1" #-} - zonkTcTypeToType env (tyVarKind tv) - ; zonk_unbound_tyvar (setTyVarKind tv kind) } - Indirect ty -> do { zty <- zonkTcTypeToType env ty - -- Small optimisation: shortern-out indirect steps - -- so that the old type may be more easily collected. - ; writeMutVar ref (Indirect zty) - ; return zty } } + MetaTv { mtv_ref = ref } + -> do { cts <- readMutVar ref + ; case cts of + Flexi -> do { kind <- {-# SCC "zonkKind1" #-} + zonkTcTypeToType env (tyVarKind tv) + ; zonk_unbound_tyvar (setTyVarKind tv kind) } + Indirect ty -> do { zty <- zonkTcTypeToType env ty + -- Small optimisation: shortern-out indirect steps + -- so that the old type may be more easily collected. + ; writeMutVar ref (Indirect zty) + ; return zty } } | otherwise = lookup_in_env where @@ -1353,6 +1397,7 @@ zonkTcLCoToLCo env co ; return (TcCastCo co1' co2') } go (TcSymCo co) = do { co' <- go co; return (mkTcSymCo co') } go (TcNthCo n co) = do { co' <- go co; return (mkTcNthCo n co') } + go (TcLRCo lr co) = do { co' <- go co; return (mkTcLRCo lr co') } go (TcTransCo co1 co2) = do { co1' <- go co1; co2' <- go co2 ; return (mkTcTransCo co1' co2') } go (TcForAllCo tv co) = ASSERT( isImmutableTyVar tv ) diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 9650b059e9..2f397a06fc 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -29,8 +29,7 @@ module TcHsType ( tcLHsType, tcCheckLHsType, tcHsContext, tcInferApps, tcHsArgTys, - ExpKind(..), ekConstraint, expArgKind, checkExpectedKind, - kindGeneralize, + kindGeneralize, checkKind, -- Sort-checking kinds tcLHsKind, @@ -967,7 +966,7 @@ kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside ; return (n, exp_k) } kc_tv (L _ (KindedTyVar n hs_k)) exp_k = do { k <- tcLHsKind hs_k - ; _ <- unifyKind k exp_k + ; checkKind k exp_k ; check_in_scope n exp_k ; return (n, k) } @@ -979,7 +978,7 @@ kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside = do { mb_thing <- tcLookupLcl_maybe n ; case mb_thing of Nothing -> return () - Just (AThing k) -> discardResult (unifyKind k exp_k) + Just (AThing k) -> checkKind k exp_k Just thing -> pprPanic "check_in_scope" (ppr thing) } ----------------------- @@ -1014,7 +1013,7 @@ tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside where tc_hs_tv (L _ (UserTyVar n)) kind = return (mkTyVar n kind) tc_hs_tv (L _ (KindedTyVar n hs_k)) kind = do { tc_kind <- tcLHsKind hs_k - ; _ <- unifyKind kind tc_kind + ; checkKind kind tc_kind ; return (mkTyVar n kind) } ----------------------------------- @@ -1201,7 +1200,7 @@ Consider Here * The pattern (T p1 p2) creates a *skolem* type variable 'a_sk', It must be a skolem so that that it retains its identity, and - TcErrors.getSkolemInfo can therreby find the binding site for the skolem. + TcErrors.getSkolemInfo can thereby find the binding site for the skolem. * The type signature pattern (f :: a->Int) binds "a" -> a_sig in the envt @@ -1274,66 +1273,75 @@ unifyKinds fun act_kinds ; mapM_ check (zip [1..] act_kinds) ; return kind } +checkKind :: TcKind -> TcKind -> TcM () +checkKind act_kind exp_kind + = do { mb_subk <- unifyKindX act_kind exp_kind + ; case mb_subk of + Just EQ -> return () + _ -> unifyKindMisMatch act_kind exp_kind } + checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM () --- A fancy wrapper for 'unifyKind', which tries +-- A fancy wrapper for 'unifyKindX', which tries -- to give decent error messages. -- (checkExpectedKind ty act_kind exp_kind) -- checks that the actual kind act_kind is compatible -- with the expected kind exp_kind -- The first argument, ty, is used only in the error message generation -checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do - traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind $$ ppr ek) - (_errs, mb_r) <- tryTc (unifyKind act_kind exp_kind) - case mb_r of - Just _ -> return () -- Unification succeeded - Nothing -> do - - -- So there's definitely an error - -- Now to find out what sort - exp_kind <- zonkTcKind exp_kind - act_kind <- zonkTcKind act_kind - - env0 <- tcInitTidyEnv - let (exp_as, _) = splitKindFunTys exp_kind - (act_as, _) = splitKindFunTys act_kind - n_exp_as = length exp_as - n_act_as = length act_as - n_diff_as = n_act_as - n_exp_as - - (env1, tidy_exp_kind) = tidyOpenKind env0 exp_kind - (env2, tidy_act_kind) = tidyOpenKind env1 act_kind - - err | n_exp_as < n_act_as -- E.g. [Maybe] - = ptext (sLit "Expecting") <+> - speakN n_diff_as <+> ptext (sLit "more argument") <> - (if n_diff_as > 1 then char 's' else empty) <+> - ptext (sLit "to") <+> quotes (ppr ty) - - -- Now n_exp_as >= n_act_as. In the next two cases, - -- n_exp_as == 0, and hence so is n_act_as - | isConstraintKind tidy_act_kind - = text "Predicate" <+> quotes (ppr ty) <+> text "used as a type" - - | isConstraintKind tidy_exp_kind - = text "Type of kind" <+> ppr tidy_act_kind <+> text "used as a constraint" - - | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind - = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty) - <+> ptext (sLit "is unlifted") - - | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind - = ptext (sLit "Expecting an unlifted type, but") <+> quotes (ppr ty) - <+> ptext (sLit "is lifted") - - | otherwise -- E.g. Monad [Int] - = ptext (sLit "Kind mis-match") $$ more_info - - more_info = sep [ ek_ctxt <+> ptext (sLit "kind") - <+> quotes (pprKind tidy_exp_kind) <> comma, - ptext (sLit "but") <+> quotes (ppr ty) <+> - ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind)] - - failWithTcM (env2, err) +checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) + = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind $$ ppr ek) + ; mb_subk <- unifyKindX act_kind exp_kind + + -- Kind unification only generates definite errors + ; case mb_subk of { + Just LT -> return () ; -- act_kind is a sub-kind of exp_kind + Just EQ -> return () ; -- The two are equal + _other -> do + + { -- So there's an error + -- Now to find out what sort + exp_kind <- zonkTcKind exp_kind + ; act_kind <- zonkTcKind act_kind + ; env0 <- tcInitTidyEnv + ; let (exp_as, _) = splitKindFunTys exp_kind + (act_as, _) = splitKindFunTys act_kind + n_exp_as = length exp_as + n_act_as = length act_as + n_diff_as = n_act_as - n_exp_as + + (env1, tidy_exp_kind) = tidyOpenKind env0 exp_kind + (env2, tidy_act_kind) = tidyOpenKind env1 act_kind + + err | n_exp_as < n_act_as -- E.g. [Maybe] + = ptext (sLit "Expecting") <+> + speakN n_diff_as <+> ptext (sLit "more argument") <> + (if n_diff_as > 1 then char 's' else empty) <+> + ptext (sLit "to") <+> quotes (ppr ty) + + -- Now n_exp_as >= n_act_as. In the next two cases, + -- n_exp_as == 0, and hence so is n_act_as + | isConstraintKind tidy_act_kind + = text "Predicate" <+> quotes (ppr ty) <+> text "used as a type" + + | isConstraintKind tidy_exp_kind + = text "Type of kind" <+> ppr tidy_act_kind <+> text "used as a constraint" + + | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind + = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty) + <+> ptext (sLit "is unlifted") + + | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind + = ptext (sLit "Expecting an unlifted type, but") <+> quotes (ppr ty) + <+> ptext (sLit "is lifted") + + | otherwise -- E.g. Monad [Int] + = ptext (sLit "Kind mis-match") $$ more_info + + more_info = sep [ ek_ctxt <+> ptext (sLit "kind") + <+> quotes (pprKind tidy_exp_kind) <> comma, + ptext (sLit "but") <+> quotes (ppr ty) <+> + ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind)] + + ; failWithTcM (env2, err) } } } \end{code} %************************************************************************ @@ -1488,5 +1496,15 @@ badPatSigTvs sig_ty bad_tvs ptext (sLit "but are actually discarded by a type synonym") ] , ptext (sLit "To fix this, expand the type synonym") , ptext (sLit "[Note: I hope to lift this restriction in due course]") ] + +unifyKindMisMatch :: TcKind -> TcKind -> TcM a +unifyKindMisMatch ki1 ki2 = do + ki1' <- zonkTcKind ki1 + ki2' <- zonkTcKind ki2 + let msg = hang (ptext (sLit "Couldn't match kind")) + 2 (sep [quotes (ppr ki1'), + ptext (sLit "against"), + quotes (ppr ki2')]) + failWithTc msg \end{code} diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 140e1c88a9..b4a27b5376 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -560,7 +560,6 @@ tcFamInstDecl top_lvl decl -- Look up the family TyCon and check for validity including -- check that toplevel type instances are not for associated types. ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; when (isTopLevel top_lvl && isTyConAssoc fam_tc) (addErr $ assocInClassErr fam_tc_lname) @@ -573,7 +572,13 @@ tcFamInstDecl1 :: TyCon -> FamInstDecl Name -> TcM FamInst -- "type instance" tcFamInstDecl1 fam_tc decl@(FamInstDecl { fid_tycon = fam_tc_name , fid_defn = TySynonym {} }) - = do { -- (1) do the work of verifying the synonym + = do { -- (0) Check it's an open type family + checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + ; checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; checkTc (isOpenSynFamilyTyCon fam_tc) + (notOpenFamily fam_tc) + + -- (1) do the work of verifying the synonym ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl -- (2) check the well-formedness of the instance @@ -840,10 +845,9 @@ tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcSigInfo) mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id - = do { uniq <- newUnique - ; loc <- getSrcSpanM - ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name - ; local_meth_name <- newLocalName sel_name + = do { let sel_occ = nameOccName sel_name + ; meth_name <- newName (mkClassOpAuxOcc sel_occ) + ; local_meth_name <- newName sel_occ -- Base the local_meth_name on the selector name, becuase -- type errors from tcInstanceMethodBody come from here @@ -853,7 +857,8 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; instTcTySig hs_ty sig_ty local_meth_name } Nothing -- No type signature - -> instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) + -> do { loc <- getSrcSpanM + ; instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) } -- Absent a type sig, there are no new scoped type variables here -- Only the ones from the instance decl itself, which are already -- in scope. Example: @@ -942,7 +947,7 @@ immediate superclasses of the dictionary we are trying to construct. In our example: dfun :: forall a. C [a] -> D [a] -> D [a] dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... -Notice teh extra (dc :: C [a]) argument compared to the previous version. +Notice the extra (dc :: C [a]) argument compared to the previous version. This gives us: @@ -962,9 +967,13 @@ dictionary constructor). No superclass is hidden inside a dfun application. The extra arguments required to satisfy the DFun Superclass Invariant -always come first, and are called the "silent" arguments. DFun types -are built (only) by MkId.mkDictFunId, so that is where we decide -what silent arguments are to be added. +always come first, and are called the "silent" arguments. You can +find out how many silent arguments there are using Id.dfunNSilent; +and then you can just drop that number of arguments to see the ones +that were in the original instance declaration. + +DFun types are built (only) by MkId.mkDictFunId, so that is where we +decide what silent arguments are to be added. In our example, if we had [Wanted] dw :: D [a] we would get via the instance: dw := dfun d1 d2 @@ -1067,16 +1076,18 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id) tc_item sig_fn (sel_id, dm_info) = case findMethodBind (idName sel_id) binds of - Just user_bind -> tc_body sig_fn sel_id standalone_deriv user_bind - Nothing -> traceTc "tc_def" (ppr sel_id) >> - tc_default sig_fn sel_id dm_info + Just (user_bind, bndr_loc) + -> tc_body sig_fn sel_id standalone_deriv user_bind bndr_loc + Nothing -> do { traceTc "tc_def" (ppr sel_id) + ; tc_default sig_fn sel_id dm_info } ---------------------- - tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id) - tc_body sig_fn sel_id generated_code rn_bind + tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name + -> SrcSpan -> TcM (TcId, LHsBind Id) + tc_body sig_fn sel_id generated_code rn_bind bndr_loc = add_meth_ctxt sel_id generated_code rn_bind $ do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id)) - ; (meth_id, local_meth_sig) <- setSrcSpan (getLoc rn_bind) $ + ; (meth_id, local_meth_sig) <- setSrcSpan bndr_loc $ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; let prags = prag_fn (idName sel_id) @@ -1094,22 +1105,23 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys tc_default sig_fn sel_id (GenDefMeth dm_name) = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name - ; tc_body sig_fn sel_id False {- Not generated code? -} meth_bind } + ; tc_body sig_fn sel_id False {- Not generated code? -} + meth_bind inst_loc } tc_default sig_fn sel_id NoDefMeth -- No default method at all = do { traceTc "tc_def: warn" (ppr sel_id) ; warnMissingMethodOrAT "method" (idName sel_id) ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars - inst_tys sel_id + inst_tys sel_id ; dflags <- getDynFlags ; return (meth_id, mkVarBind meth_id $ mkLHsWrap lam_wrapper (error_rhs dflags)) } where - error_rhs dflags = L loc $ HsApp error_fun (error_msg dflags) - error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L loc (HsLit (HsStringPrim (unsafeMkFastBytesString (error_string dflags)))) + error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) + error_fun = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID + error_msg dflags = L inst_loc (HsLit (HsStringPrim (unsafeMkFastBytesString (error_string dflags)))) meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) - error_string dflags = showSDoc dflags (hcat [ppr loc, text "|", ppr sel_id ]) + error_string dflags = showSDoc dflags (hcat [ppr inst_loc, text "|", ppr sel_id ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method @@ -1126,14 +1138,14 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars)) ; (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars - inst_tys sel_id + inst_tys sel_id ; dm_id <- tcLookupId dm_name ; let dm_inline_prag = idInlinePragma dm_id rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $ HsVar dm_id local_meth_id = sig_id local_meth_sig - meth_bind = mkVarBind local_meth_id (L loc rhs) + meth_bind = mkVarBind local_meth_id (L inst_loc rhs) meth_id1 = meth_id `setInlinePragma` dm_inline_prag -- Copy the inline pragma (if any) from the default -- method to this version. Note [INLINE and default methods] @@ -1151,7 +1163,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- currently they are rejected with -- "INLINE pragma lacks an accompanying binding" - ; return (meth_id1, L loc bind) } + ; return (meth_id1, L inst_loc bind) } ---------------------- mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags @@ -1171,10 +1183,10 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- and the specialisation would do nothing. (Indeed it'll provoke -- a warning from the desugarer | otherwise - = [ L loc (SpecPrag meth_id wrap inl) - | L loc (SpecPrag _ wrap inl) <- spec_inst_prags] + = [ L inst_loc (SpecPrag meth_id wrap inl) + | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] - loc = getSrcSpan dfun_id + inst_loc = getSrcSpan dfun_id -- For instance decls that come from standalone deriving clauses -- we want to print out the full source code if there's an error @@ -1442,4 +1454,8 @@ badFamInstDecl tc_name = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tc_name) , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] + +notOpenFamily :: TyCon -> SDoc +notOpenFamily tc + = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc) \end{code} diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 2c2dc54c1b..db7f36297f 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -8,7 +8,7 @@ module TcInteract ( solveInteractGiven, -- Solves [EvVar],GivenLoc - solveInteractCts, -- Solves [Cts] + solveInteract, -- Solves Cts ) where #include "HsVersions.h" @@ -24,7 +24,7 @@ import Coercion( mkAxInstRHS ) import Var import TcType -import PrelNames (singIClassName) +import PrelNames (singIClassName, ipClassNameKey ) import Class import TyCon @@ -46,10 +46,10 @@ import Bag import Control.Monad ( foldM ) import VarEnv -import qualified Data.Traversable as Traversable import Control.Monad( when, unless ) import Pair () +import Unique( hasKey ) import UniqFM import FastString ( sLit ) import DynFlags @@ -85,49 +85,53 @@ Note [Basic Simplifier Plan] If in Step 1 no such element exists, we have exceeded our context-stack depth and will simply fail. \begin{code} - -solveInteractCts :: [Ct] -> TcS (Bag Implication) --- Returns a bag of residual implications that have arisen while solving --- this particular worklist. -solveInteractCts cts - = do { traceTcS "solveInteractCtS" (vcat [ text "cts =" <+> ppr cts ]) - ; updWorkListTcS (appendWorkListCt cts) >> solveInteract - ; impls <- getTcSImplics - ; updTcSImplics (const emptyBag) -- Nullify residual implications - ; return impls } - -solveInteractGiven :: GivenLoc -> [EvVar] -> TcS (Bag Implication) +solveInteractGiven :: CtLoc -> [TcTyVar] -> [EvVar] -> TcS () -- In principle the givens can kick out some wanteds from the inert -- resulting in solving some more wanted goals here which could emit -- implications. That's why I return a bag of implications. Not sure -- if this can happen in practice though. -solveInteractGiven gloc evs - = solveInteractCts (map mk_noncan evs) +solveInteractGiven loc fsks givens + = do { implics <- solveInteract (fsk_bag `unionBags` given_bag) + ; ASSERT( isEmptyBag implics ) + return () } -- We do not decompose *given* polymorphic equalities + -- (forall a. t1 ~ forall a. t2) + -- What would the evidence look like?! + -- See Note [Do not decompose given polytype equalities] + -- in TcCanonical where - mk_noncan ev = CNonCanonical { cc_ev = Given { ctev_gloc = gloc - , ctev_evtm = EvId ev - , ctev_pred = evVarPred ev } - , cc_depth = 0 } + given_bag = listToBag [ mkNonCanonical loc $ CtGiven { ctev_evtm = EvId ev_id + , ctev_pred = evVarPred ev_id } + | ev_id <- givens ] + + fsk_bag = listToBag [ mkNonCanonical loc $ CtGiven { ctev_evtm = EvCoercion (mkTcReflCo tv_ty) + , ctev_pred = pred } + | tv <- fsks + , let FlatSkol fam_ty = tcTyVarDetails tv + tv_ty = mkTyVarTy tv + pred = mkTcEqPred fam_ty tv_ty + ] -- The main solver loop implements Note [Basic Simplifier Plan] --------------------------------------------------------------- -solveInteract :: TcS () --- Returns the final InertSet in TcS, WorkList will be eventually empty. -solveInteract +solveInteract :: Cts -> TcS (Bag Implication) +-- Returns the final InertSet in TcS +-- Has no effect on work-list or residual-iplications +solveInteract cts = {-# SCC "solveInteract" #-} + withWorkList cts $ do { dyn_flags <- getDynFlags - ; let max_depth = ctxtStkDepth dyn_flags - solve_loop - = {-# SCC "solve_loop" #-} - do { sel <- selectNextWorkItem max_depth - ; case sel of - NoWorkRemaining -- Done, successfuly (modulo frozen) - -> return () - MaxDepthExceeded ct -- Failure, depth exceeded - -> wrapErrTcS $ solverDepthErrorTcS (cc_depth ct) [ct] - NextWorkItem ct -- More work, loop around! - -> runSolverPipeline thePipeline ct >> solve_loop } - ; solve_loop } + ; solve_loop (ctxtStkDepth dyn_flags) } + where + solve_loop max_depth + = {-# SCC "solve_loop" #-} + do { sel <- selectNextWorkItem max_depth + ; case sel of + NoWorkRemaining -- Done, successfuly (modulo frozen) + -> return () + MaxDepthExceeded ct -- Failure, depth exceeded + -> wrapErrTcS $ solverDepthErrorTcS ct + NextWorkItem ct -- More work, loop around! + -> do { runSolverPipeline thePipeline ct; solve_loop max_depth } } type WorkItem = Ct type SimplifierStage = WorkItem -> TcS StopOrContinue @@ -147,14 +151,15 @@ selectNextWorkItem max_depth = updWorkListTcS_return pick_next where pick_next :: WorkList -> (SelectWorkItem, WorkList) - pick_next wl = case selectWorkItem wl of - (Nothing,_) - -> (NoWorkRemaining,wl) -- No more work - (Just ct, new_wl) - | cc_depth ct > max_depth -- Depth exceeded - -> (MaxDepthExceeded ct,new_wl) - (Just ct, new_wl) - -> (NextWorkItem ct, new_wl) -- New workitem and worklist + pick_next wl + = case selectWorkItem wl of + (Nothing,_) + -> (NoWorkRemaining,wl) -- No more work + (Just ct, new_wl) + | ctLocDepth (cc_loc ct) > max_depth -- Depth exceeded + -> (MaxDepthExceeded ct,new_wl) + (Just ct, new_wl) + -> (NextWorkItem ct, new_wl) -- New workitem and worklist runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline -> WorkItem -- The work item @@ -166,6 +171,7 @@ runSolverPipeline pipeline workItem vcat [ ptext (sLit "work item = ") <+> ppr workItem , ptext (sLit "inerts = ") <+> ppr initial_is] + ; bumpStepCountTcS -- One step for each constraint processed ; final_res <- run_pipeline pipeline (ContinueWith workItem) ; final_is <- getTcSInerts @@ -173,10 +179,11 @@ runSolverPipeline pipeline workItem Stop -> do { traceTcS "End solver pipeline (discharged) }" (ptext (sLit "inerts = ") <+> ppr final_is) ; return () } - ContinueWith ct -> do { traceTcS "End solver pipeline (not discharged) }" $ + ContinueWith ct -> do { traceFireTcS ct (ptext (sLit "Kept as inert:") <+> ppr ct) + ; traceTcS "End solver pipeline (not discharged) }" $ vcat [ ptext (sLit "final_item = ") <+> ppr ct , ptext (sLit "inerts = ") <+> ppr final_is] - ; updInertSetTcS ct } + ; insertInertItemTcS ct } } where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue -> TcS StopOrContinue run_pipeline [] res = return res @@ -215,39 +222,13 @@ React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canoni \begin{code} thePipeline :: [(String,SimplifierStage)] -thePipeline = [ ("lookup-in-inerts", lookupInInertsStage) - , ("canonicalization", canonicalizationStage) +thePipeline = [ ("canonicalization", TcCanonical.canonicalize) , ("spontaneous solve", spontaneousSolveStage) , ("interact with inerts", interactWithInertsStage) , ("top-level reactions", topReactionsStage) ] \end{code} -\begin{code} - --- A quick lookup everywhere to see if we know about this constraint --------------------------------------------------------------------- -lookupInInertsStage :: SimplifierStage -lookupInInertsStage ct - | Wanted { ctev_evar = ev_id, ctev_pred = pred } <- cc_ev ct - = do { is <- getTcSInerts - ; case lookupInInerts is pred of - Just ctev - | not (isDerived ctev) - -> do { setEvBind ev_id (ctEvTerm ctev) - ; return Stop } - _ -> continueWith ct } - | otherwise -- I could do something like that for givens - -- as well I suppose but it is not a big deal - = continueWith ct - - --- The canonicalization stage, see TcCanonical for details ----------------------------------------------------------- -canonicalizationStage :: SimplifierStage -canonicalizationStage = TcCanonical.canonicalize -\end{code} - ********************************************************************************* * * The spontaneous-solve Stage @@ -277,134 +258,93 @@ Case 2: Functional Dependencies \begin{code} spontaneousSolveStage :: SimplifierStage spontaneousSolveStage workItem - = do { mSolve <- trySpontaneousSolve workItem - ; spont_solve mSolve } - where spont_solve SPCantSolve - | isCTyEqCan workItem -- Unsolved equality - = do { kickOutRewritableInerts workItem -- NB: will add workItem in inerts - ; return Stop } - | otherwise - = continueWith workItem - spont_solve (SPSolved workItem') -- Post: workItem' must be equality - = do { bumpStepCountTcS - ; traceFireTcS (cc_depth workItem) $ - ptext (sLit "Spontaneous:") <+> ppr workItem - - -- NB: will add the item in the inerts - ; kickOutRewritableInerts workItem' - -- .. and Stop - ; return Stop } - -kickOutRewritableInerts :: Ct -> TcS () --- Pre: ct is a CTyEqCan --- Post: The TcS monad is left with the thinner non-rewritable inerts; but which --- contains the new constraint. --- The rewritable end up in the worklist -kickOutRewritableInerts ct - = {-# SCC "kickOutRewritableInerts" #-} - do { traceTcS "kickOutRewritableInerts" $ text "workitem = " <+> ppr ct - ; (wl,ieqs) <- {-# SCC "kick_out_rewritable" #-} - modifyInertTcS (kick_out_rewritable ct) - ; traceTcS "Kicked out the following constraints" $ ppr wl - ; is <- getTcSInerts - ; traceTcS "Remaining inerts are" $ ppr is - - -- Step 1: Rewrite as many of the inert_eqs on the spot! - -- NB: if it is a given constraint just use the cached evidence - -- to optimize e.g. mkRefl coercions from spontaneously solved cts. - ; bnds <- getTcEvBindsMap - ; let ct_coercion = getCtCoercion bnds ct - - ; new_ieqs <- {-# SCC "rewriteInertEqsFromInertEq" #-} - rewriteInertEqsFromInertEq (cc_tyvar ct, - ct_coercion,cc_ev ct) ieqs - ; let upd_eqs is = is { inert_cans = new_ics } - where ics = inert_cans is - new_ics = ics { inert_eqs = new_ieqs } - ; modifyInertTcS (\is -> ((), upd_eqs is)) - - ; is <- getTcSInerts - ; traceTcS "Final inerts are" $ ppr is - - -- Step 2: Add the new guy in - ; updInertSetTcS ct - - ; traceTcS "Kick out" (ppr ct $$ ppr wl) - ; updWorkListTcS (unionWorkList wl) } - -rewriteInertEqsFromInertEq :: (TcTyVar, TcCoercion, CtEvidence) -- A new substitution - -> TyVarEnv Ct -- All the inert equalities - -> TcS (TyVarEnv Ct) -- The new inert equalities -rewriteInertEqsFromInertEq (subst_tv, _subst_co, subst_fl) ieqs --- The goal: traverse the inert equalities and throw some of them back to the worklist --- if you have to rewrite and recheck them for occurs check errors. --- To see which ones we must throw out see Note [Delicate equality kick-out] - = do { mieqs <- Traversable.mapM do_one ieqs - ; traceTcS "Original inert equalities:" (ppr ieqs) - ; let flatten_justs elem venv - | Just act <- elem = extendVarEnv venv (cc_tyvar act) act - | otherwise = venv - final_ieqs = foldVarEnv flatten_justs emptyVarEnv mieqs - ; traceTcS "Remaining inert equalities:" (ppr final_ieqs) - ; return final_ieqs } - - where do_one ct - | subst_fl `canRewrite` fl && (subst_tv `elemVarSet` tyVarsOfCt ct) - = if fl `canRewrite` subst_fl then - -- If also the inert can rewrite the subst then there is no danger of - -- occurs check errors sor keep it there. No need to rewrite the inert equality - -- (as we did in the past) because of point (8) of - -- Note [Detailed InertCans Invariants] and - return (Just ct) - -- used to be: rewrite_on_the_spot ct >>= ( return . Just ) - else -- We have to throw inert back to worklist for occurs checks - updWorkListTcS (extendWorkListEq ct) >> return Nothing - | otherwise -- Just keep it there - = return (Just ct) - where - fl = cc_ev ct - -kick_out_rewritable :: Ct - -> InertSet - -> ((WorkList, TyVarEnv Ct),InertSet) --- Post: returns ALL inert equalities, to be dealt with later --- -kick_out_rewritable ct is@(IS { inert_cans = - IC { inert_eqs = eqmap - , inert_eq_tvs = inscope - , inert_dicts = dictmap - , inert_funeqs = funeqmap - , inert_irreds = irreds } - , inert_frozen = frozen }) - = ((kicked_out,eqmap), remaining) + = do { mb_solved <- trySpontaneousSolve workItem + ; case mb_solved of + SPCantSolve + | CTyEqCan { cc_tyvar = tv, cc_ev = fl } <- workItem + -- Unsolved equality + -> do { n_kicked <- kickOutRewritable (ctEvFlavour fl) tv + ; traceFireTcS workItem $ + ptext (sLit "Kept as inert") <+> ppr_kicked n_kicked <> colon + <+> ppr workItem + ; insertInertItemTcS workItem + ; return Stop } + | otherwise + -> continueWith workItem + + 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 <- kickOutRewritable Given new_tv + ; traceFireTcS workItem $ + ptext (sLit "Spontaneously solved") <+> ppr_kicked n_kicked <> colon + <+> ppr workItem + ; return Stop } } + +ppr_kicked :: Int -> SDoc +ppr_kicked 0 = empty +ppr_kicked n = parens (int n <+> ptext (sLit "kicked out")) +\end{code} +Note [Spontaneously solved in TyBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we encounter a constraint ([W] alpha ~ tau) which can be spontaneously solved, +we record the equality on the TyBinds of the TcSMonad. In the past, we used to also +add a /given/ version of the constraint ([G] alpha ~ tau) to the inert +canonicals -- and potentially kick out other equalities that mention alpha. + +Then, the flattener only had to look in the inert equalities during flattening of a +type (TcCanonical.flattenTyVar). + +However it is a bit silly to record these equalities /both/ in the inerts AND the +TyBinds, so we have now eliminated spontaneously solved equalities from the inerts, +and only record them in the TyBinds of the TcS monad. The flattener is now consulting +these binds /and/ the inerts for potentially unsolved or other given equalities. + +\begin{code} +kickOutRewritable :: CtFlavour -- Flavour of the equality that is + -- being added to the inert set + -> TcTyVar -- The new equality is tv ~ ty + -> TcS Int +kickOutRewritable new_flav new_tv + = do { wl <- modifyInertTcS kick_out + ; traceTcS "kickOutRewritable" $ + vcat [ text "tv = " <+> ppr new_tv + , ptext (sLit "Kicked out =") <+> ppr wl] + ; updWorkListTcS (appendWorkList wl) + ; return (workListSize wl) } where - rest_out = fro_out `andCts` dicts_out `andCts` irs_out - kicked_out = WorkList { wl_eqs = [] - , wl_funeqs = bagToList feqs_out - , wl_rest = bagToList rest_out } - - remaining = is { inert_cans = IC { inert_eqs = emptyVarEnv - , inert_eq_tvs = inscope - -- keep the same, safe and cheap - , inert_dicts = dicts_in - , inert_funeqs = feqs_in - , inert_irreds = irs_in } - , inert_frozen = fro_in } + kick_out :: InertSet -> (WorkList, InertSet) + kick_out (is@(IS { inert_cans = IC { inert_eqs = tv_eqs + , inert_dicts = dictmap + , inert_funeqs = funeqmap + , inert_irreds = irreds + , inert_insols = insols } })) + = (kicked_out, is { inert_cans = inert_cans_in }) -- NB: Notice that don't rewrite - -- inert_solved, inert_flat_cache and inert_solved_funeqs + -- inert_solved_dicts, and inert_solved_funeqs -- optimistically. But when we lookup we have to take the -- subsitution into account - fl = cc_ev ct - tv = cc_tyvar ct - - (feqs_out, feqs_in) = partCtFamHeadMap rewritable funeqmap - (dicts_out, dicts_in) = partitionCCanMap rewritable dictmap - - (irs_out, irs_in) = partitionBag rewritable irreds - (fro_out, fro_in) = partitionBag rewritable frozen - - rewritable ct = (fl `canRewrite` cc_ev ct) && - (tv `elemVarSet` tyVarsOfCt ct) + where + inert_cans_in = IC { inert_eqs = tv_eqs_in + , inert_dicts = dicts_in + , inert_funeqs = feqs_in + , inert_irreds = irs_in + , inert_insols = insols_in } + + kicked_out = WorkList { wl_eqs = varEnvElts tv_eqs_out + , wl_funeqs = foldrBag insertDeque emptyDeque feqs_out + , wl_rest = bagToList (dicts_out `andCts` irs_out + `andCts` insols_out) } + + (tv_eqs_out, tv_eqs_in) = partitionVarEnv kick_out_eq tv_eqs + (feqs_out, feqs_in) = partCtFamHeadMap kick_out_ct funeqmap + (dicts_out, dicts_in) = partitionCCanMap kick_out_ct dictmap + (irs_out, irs_in) = partitionBag kick_out_ct irreds + (insols_out, insols_in) = partitionBag kick_out_ct insols + -- Kick out even insolubles; see Note [Kick out insolubles] + + kick_out_ct inert_ct = new_flav `canRewrite` (ctFlavour inert_ct) && + (new_tv `elemVarSet` tyVarsOfCt inert_ct) -- NB: tyVarsOfCt will return the type -- variables /and the kind variables/ that are -- directly visible in the type. Hence we will @@ -414,11 +354,26 @@ kick_out_rewritable ct is@(IS { inert_cans = -- constraints that mention type variables whose -- kinds could contain this variable! + kick_out_eq inert_ct = kick_out_ct inert_ct && + not (ctFlavour inert_ct `canRewrite` new_flav) + -- If also the inert can rewrite the subst then there is no danger of + -- occurs check errors sor keep it there. No need to rewrite the inert equality + -- (as we did in the past) because of point (8) of + -- See Note [Detailed InertCans Invariants] + -- and Note [Delicate equality kick-out] \end{code} +Note [Kick out insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an insoluble alpha ~ [alpha], which is insoluble +because an occurs check. And then we unify alpha := [Int]. +Then we really want to rewrite the insouluble to [Int] ~ [[Int]]. +Now it can be decomposed. Otherwise we end up with a "Can't match +[Int] ~ [[Int]]" which is true, but a bit confusing because the +outer type constructors match. + Note [Delicate equality kick-out] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Delicate: When kicking out rewritable constraints, it would be safe to simply kick out all rewritable equalities, but instead we only kick out those @@ -443,7 +398,8 @@ but this is no longer necessary see Note [Non-idempotent inert substitution]. \begin{code} data SPSolveResult = SPCantSolve - | SPSolved WorkItem + | 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 @@ -453,22 +409,24 @@ data SPSolveResult = SPCantSolve -- See Note [Touchables and givens] trySpontaneousSolve :: WorkItem -> TcS SPSolveResult trySpontaneousSolve workItem@(CTyEqCan { cc_ev = gw - , cc_tyvar = tv1, cc_rhs = xi, cc_depth = d }) + , cc_tyvar = tv1, cc_rhs = xi, cc_loc = d }) | isGiven gw = return SPCantSolve | Just tv2 <- tcGetTyVar_maybe xi - = do { tch1 <- isTouchableMetaTyVar tv1 - ; tch2 <- isTouchableMetaTyVar tv2 + = do { tch1 <- isTouchableMetaTyVarTcS tv1 + ; tch2 <- isTouchableMetaTyVarTcS tv2 ; case (tch1, tch2) of (True, True) -> trySpontaneousEqTwoWay d gw tv1 tv2 (True, False) -> trySpontaneousEqOneWay d gw tv1 xi (False, True) -> trySpontaneousEqOneWay d gw tv2 (mkTyVarTy tv1) _ -> return SPCantSolve } | otherwise - = do { tch1 <- isTouchableMetaTyVar tv1 + = do { tch1 <- isTouchableMetaTyVarTcS tv1 ; if tch1 then trySpontaneousEqOneWay d gw tv1 xi - else do { traceTcS "Untouchable LHS, can't spontaneously solve workitem:" $ - ppr workItem + else do { untch <- getUntouchables + ; traceTcS "Untouchable LHS, can't spontaneously solve workitem" $ + vcat [text "Untouchables =" <+> ppr untch + , text "Workitem =" <+> ppr workItem ] ; return SPCantSolve } } @@ -478,25 +436,28 @@ trySpontaneousSolve workItem@(CTyEqCan { cc_ev = gw trySpontaneousSolve _ = return SPCantSolve ---------------- -trySpontaneousEqOneWay :: SubGoalDepth - -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult +trySpontaneousEqOneWay :: CtLoc -> CtEvidence + -> TcTyVar -> Xi -> TcS SPSolveResult -- tv is a MetaTyVar, not untouchable trySpontaneousEqOneWay d gw tv xi | not (isSigTyVar tv) || isTyVarTy xi + , typeKind xi `tcIsSubKind` tyVarKind tv = solveWithIdentity d gw tv xi | otherwise -- Still can't solve, sig tyvar and non-variable rhs = return SPCantSolve ---------------- -trySpontaneousEqTwoWay :: SubGoalDepth - -> CtEvidence -> TcTyVar -> TcTyVar -> TcS SPSolveResult +trySpontaneousEqTwoWay :: CtLoc -> CtEvidence + -> TcTyVar -> TcTyVar -> TcS SPSolveResult -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here trySpontaneousEqTwoWay d gw tv1 tv2 - = do { let k1_sub_k2 = k1 `tcIsSubKind` k2 - ; if k1_sub_k2 && nicer_to_update_tv2 - then solveWithIdentity d gw tv2 (mkTyVarTy tv1) - else solveWithIdentity d gw tv1 (mkTyVarTy tv2) } + | k1 `tcIsSubKind` k2 && nicer_to_update_tv2 + = solveWithIdentity d gw tv2 (mkTyVarTy tv1) + | k2 `tcIsSubKind` k1 + = solveWithIdentity d gw tv1 (mkTyVarTy tv2) + | otherwise + = return SPCantSolve where k1 = tyVarKind tv1 k2 = tyVarKind tv2 @@ -504,7 +465,7 @@ trySpontaneousEqTwoWay d gw tv1 tv2 \end{code} Note [Kind errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~ Consider the wanted problem: alpha ~ (# Int, Int #) where alpha :: ArgKind and (# Int, Int #) :: (#). We can't spontaneously solve this constraint, @@ -575,8 +536,7 @@ unification variables as RHS of type family equations: F xis ~ alpha. \begin{code} ---------------- -solveWithIdentity :: SubGoalDepth - -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult +solveWithIdentity :: CtLoc -> 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 @@ -589,10 +549,10 @@ solveWithIdentity :: SubGoalDepth -- 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 d wd tv xi +solveWithIdentity _d wd tv xi = do { let tv_ty = mkTyVarTy tv ; traceTcS "Sneaky unification:" $ - vcat [text "Constraint:" <+> ppr wd, + 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) ] @@ -604,18 +564,11 @@ solveWithIdentity d wd tv xi ; setWantedTyBind tv xi' ; let refl_evtm = EvCoercion (mkTcReflCo xi') - refl_pred = mkTcEqPred tv_ty xi' ; when (isWanted wd) $ setEvBind (ctev_evar wd) refl_evtm - ; let given_fl = Given { ctev_gloc = mkGivenLoc (ctev_wloc wd) UnkSkol - , ctev_pred = refl_pred - , ctev_evtm = refl_evtm } - - ; return $ - SPSolved (CTyEqCan { cc_ev = given_fl - , cc_tyvar = tv, cc_rhs = xi', cc_depth = d }) } + ; return (SPSolved tv) } \end{code} @@ -656,21 +609,10 @@ or, equivalently, -- Interaction result of WorkItem <~> Ct data InteractResult - = IRWorkItemConsumed { ir_fire :: String } - | IRInertConsumed { ir_fire :: String } - | IRKeepGoing { ir_fire :: String } - -irWorkItemConsumed :: String -> TcS InteractResult -irWorkItemConsumed str = return (IRWorkItemConsumed str) - -irInertConsumed :: String -> TcS InteractResult -irInertConsumed str = return (IRInertConsumed str) - -irKeepGoing :: String -> TcS InteractResult -irKeepGoing str = return (IRKeepGoing str) --- You can't discard neither workitem or inert, but you must keep --- going. It's possible that new work is waiting in the TcS worklist. - + = IRWorkItemConsumed { ir_fire :: String } -- Work item discharged by interaction; stop + | IRReplace { ir_fire :: String } -- Inert item replaced by work item; stop + | IRInertConsumed { ir_fire :: String } -- Inert item consumed, keep going with work item + | IRKeepGoing { ir_fire :: String } -- Inert item remains, keep going with work item interactWithInertsStage :: WorkItem -> TcS StopOrContinue -- Precondition: if the workitem is a CTyEqCan then it will not be able to @@ -682,7 +624,7 @@ interactWithInertsStage wi ; foldlBagM interact_next (ContinueWith wi) rels } where interact_next Stop atomic_inert - = updInertSetTcS atomic_inert >> return Stop + = do { insertInertItemTcS atomic_inert; return Stop } interact_next (ContinueWith wi) atomic_inert = do { ir <- doInteractWithInert atomic_inert wi ; let mk_msg rule keep_doc @@ -691,21 +633,22 @@ interactWithInertsStage wi , ptext (sLit "WorkItem =") <+> ppr wi ] ; case ir of IRWorkItemConsumed { ir_fire = rule } - -> do { bumpStepCountTcS - ; traceFireTcS (cc_depth wi) - (mk_msg rule (text "WorkItemConsumed")) - ; updInertSetTcS atomic_inert + -> do { traceFireTcS wi (mk_msg rule (text "WorkItemConsumed")) + ; insertInertItemTcS atomic_inert + ; return Stop } + IRReplace { ir_fire = rule } + -> do { traceFireTcS atomic_inert + (mk_msg rule (text "InertReplace")) + ; insertInertItemTcS wi ; return Stop } IRInertConsumed { ir_fire = rule } - -> do { bumpStepCountTcS - ; traceFireTcS (cc_depth atomic_inert) + -> do { traceFireTcS atomic_inert (mk_msg rule (text "InertItemConsumed")) ; return (ContinueWith wi) } - IRKeepGoing {} -- Should we do a bumpStepCountTcS? No for now. - -> do { updInertSetTcS atomic_inert + IRKeepGoing {} + -> do { insertInertItemTcS atomic_inert ; return (ContinueWith wi) } } - \end{code} \begin{code} @@ -713,57 +656,60 @@ interactWithInertsStage wi doInteractWithInert :: Ct -> Ct -> TcS InteractResult -- Identical class constraints. -doInteractWithInert - inertItem@(CDictCan { cc_ev = fl1, cc_class = cls1, cc_tyargs = tys1 }) - workItem@(CDictCan { cc_ev = fl2, cc_class = cls2, cc_tyargs = tys2 }) - +doInteractWithInert inertItem@(CDictCan { cc_ev = fl1, cc_class = cls1, cc_tyargs = tys1, cc_loc = loc1 }) + workItem@(CDictCan { cc_ev = fl2, cc_class = cls2, cc_tyargs = tys2, cc_loc = loc2 }) | cls1 == cls2 = do { let pty1 = mkClassPred cls1 tys1 pty2 = mkClassPred cls2 tys2 - inert_pred_loc = (pty1, pprFlavorArising fl1) - work_item_pred_loc = (pty2, pprFlavorArising fl2) + inert_pred_loc = (pty1, pprArisingAt loc1) + work_item_pred_loc = (pty2, pprArisingAt loc2) - ; traceTcS "doInteractWithInert" (vcat [ text "inertItem = " <+> ppr inertItem - , text "workItem = " <+> ppr workItem ]) - ; let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc - ; any_fundeps <- rewriteWithFunDeps fd_eqns tys2 fl2 + ; fd_work <- rewriteWithFunDeps fd_eqns loc2 -- 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] - -- - ; case any_fundeps of + ; traceTcS "doInteractWithInert:dict" + (vcat [ text "inertItem =" <+> ppr inertItem + , text "workItem =" <+> ppr workItem + , text "fundeps =" <+> ppr fd_work ]) + + ; case fd_work of -- No Functional Dependencies - Nothing - | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" fl1 workItem - | otherwise -> irKeepGoing "NOP" + [] | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" fl1 workItem + | otherwise -> return (IRKeepGoing "NOP") -- Actual Functional Dependencies - Just (_rewritten_tys2, fd_work) - -- Standard thing: create derived fds and keep on going. Importantly we don't + _ | cls1 `hasKey` ipClassNameKey + , isGiven fl1, isGiven fl2 -- See Note [Shadowing of Implicit Parameters] + -> return (IRReplace ("Replace IP")) + + -- 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. - -> do { emitFDWorkAsDerived fd_work (cc_depth workItem) - ; irKeepGoing "Cls/Cls (new fundeps)" } -- Just keep going without droping the inert + | otherwise + -> do { updWorkListTcS (extendWorkListEqs fd_work) + ; return (IRKeepGoing "Cls/Cls (new fundeps)") } -- Just keep going without droping the inert } -- Two pieces of irreducible evidence: if their types are *exactly identical* -- we can rewrite them. We can never improve using this: -- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not -- mean that (ty1 ~ ty2) -doInteractWithInert (CIrredEvCan { cc_ev = ifl, cc_ty = ty1 }) - workItem@(CIrredEvCan { cc_ty = ty2 }) - | ty1 `eqType` ty2 +doInteractWithInert (CIrredEvCan { cc_ev = ifl }) + workItem@(CIrredEvCan { cc_ev = wfl }) + | ctEvPred ifl `eqType` ctEvPred wfl = solveOneFromTheOther "Irred/Irred" ifl workItem -doInteractWithInert ii@(CFunEqCan { cc_ev = fl1, cc_fun = tc1 - , cc_tyargs = args1, cc_rhs = xi1, cc_depth = d1 }) - wi@(CFunEqCan { cc_ev = fl2, cc_fun = tc2 - , cc_tyargs = args2, cc_rhs = xi2, cc_depth = d2 }) - | fl1 `canSolve` fl2 && lhss_match - = do { traceTcS "interact with inerts: FunEq/FunEq" $ +doInteractWithInert ii@(CFunEqCan { cc_ev = ev1, cc_fun = tc1 + , cc_tyargs = args1, cc_rhs = xi1, cc_loc = d1 }) + wi@(CFunEqCan { cc_ev = ev2, cc_fun = tc2 + , cc_tyargs = args2, cc_rhs = xi2, cc_loc = d2 }) + | fl1 `canSolve` fl2 + = ASSERT( lhss_match ) -- extractRelevantInerts ensures this + do { traceTcS "interact with inerts: FunEq/FunEq" $ vcat [ text "workItem =" <+> ppr wi , text "inertItem=" <+> ppr ii ] @@ -774,14 +720,15 @@ doInteractWithInert ii@(CFunEqCan { cc_ev = fl1, cc_fun = tc1 -- xdecomp : (F args ~ xi2) -> [(xi2 ~ xi1)] xdecomp x = [EvCoercion (mk_sym_co x `mkTcTransCo` co1)] - ; ctevs <- xCtFlavor_cache False fl2 [mkTcEqPred xi2 xi1] xev - -- Why not simply xCtFlavor? See Note [Cache-caused loops] + ; ctevs <- xCtFlavor ev2 [mkTcEqPred xi2 xi1] xev + -- No caching! See Note [Cache-caused loops] -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation] - ; add_to_work d2 ctevs - ; irWorkItemConsumed "FunEq/FunEq" } + ; emitWorkNC d2 ctevs + ; return (IRWorkItemConsumed "FunEq/FunEq") } - | fl2 `canSolve` fl1 && lhss_match - = do { traceTcS "interact with inerts: FunEq/FunEq" $ + | fl2 `canSolve` fl1 + = ASSERT( lhss_match ) -- extractRelevantInerts ensures this + do { traceTcS "interact with inerts: FunEq/FunEq" $ vcat [ text "workItem =" <+> ppr wi , text "inertItem=" <+> ppr ii ] @@ -792,23 +739,20 @@ doInteractWithInert ii@(CFunEqCan { cc_ev = fl1, cc_fun = tc1 -- xdecomp : (F args ~ xi1) -> [(xi2 ~ xi1)] xdecomp x = [EvCoercion (mkTcSymCo co2 `mkTcTransCo` evTermCoercion x)] - ; ctevs <- xCtFlavor_cache False fl1 [mkTcEqPred xi2 xi1] xev - -- Why not simply xCtFlavor? See Note [Cache-caused loops] - -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation] + ; ctevs <- xCtFlavor ev1 [mkTcEqPred xi2 xi1] xev + -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation] - ; add_to_work d1 ctevs - ; irInertConsumed "FunEq/FunEq"} + ; emitWorkNC d1 ctevs + ; return (IRInertConsumed "FunEq/FunEq") } where - add_to_work d [ctev] = updWorkListTcS $ extendWorkListEq $ - CNonCanonical {cc_ev = ctev, cc_depth = d} - add_to_work _ _ = return () - lhss_match = tc1 == tc2 && eqTypes args1 args2 - co1 = evTermCoercion $ ctEvTerm fl1 - co2 = evTermCoercion $ ctEvTerm fl2 + co1 = evTermCoercion $ ctEvTerm ev1 + co2 = evTermCoercion $ ctEvTerm ev2 mk_sym_co x = mkTcSymCo (evTermCoercion x) + fl1 = ctEvFlavour ev1 + fl2 = ctEvFlavour ev2 -doInteractWithInert _ _ = irKeepGoing "NOP" +doInteractWithInert _ _ = return (IRKeepGoing "NOP") \end{code} @@ -864,13 +808,6 @@ I can think of two ways to fix this: error if we get multiple givens for the same implicit parameter. - - - - - - - Note [Cache-caused loops] ~~~~~~~~~~~~~~~~~~~~~~~~~ It is very dangerous to cache a rewritten wanted family equation as 'solved' in our @@ -903,7 +840,6 @@ just an optimization so we don't lose anything in terms of completeness of solving. \begin{code} - solveOneFromTheOther :: String -- Info -> CtEvidence -- Inert -> Ct -- WorkItem @@ -913,26 +849,61 @@ solveOneFromTheOther :: String -- Info -- 2) ip/class/irred evidence (no coercions) only solveOneFromTheOther info ifl workItem | isDerived wfl - = irWorkItemConsumed ("Solved[DW] " ++ info) + = return (IRWorkItemConsumed ("Solved[DW] " ++ info)) | isDerived ifl -- The inert item is Derived, we can just throw it away, -- The workItem is inert wrt earlier inert-set items, -- so it's safe to continue on from this point - = irInertConsumed ("Solved[DI] " ++ info) + = return (IRInertConsumed ("Solved[DI] " ++ info)) - | otherwise - = ASSERT( ifl `canSolve` wfl ) - -- Because of Note [The Solver Invariant], plus Derived dealt with - do { case wfl of - Wanted { ctev_evar = ev_id } -> setEvBind ev_id (ctEvTerm ifl) - _ -> return () - -- Overwrite the binding, if one exists - -- If both are Given, we already have evidence; no need to duplicate - ; irWorkItemConsumed ("Solved " ++ info) } + | CtWanted { ctev_evar = ev_id } <- wfl + = do { setEvBind ev_id (ctEvTerm ifl); return (IRWorkItemConsumed ("Solved(w) " ++ info)) } + + | CtWanted { ctev_evar = ev_id } <- ifl + = do { setEvBind ev_id (ctEvTerm wfl); return (IRInertConsumed ("Solved(g) " ++ info)) } + + | otherwise -- If both are Given, we already have evidence; no need to duplicate + -- But the work item *overrides* the inert item (hence IRReplace) + -- See Note [Shadowing of Implicit Parameters] + = return (IRReplace ("Replace(gg) " ++ info)) where wfl = cc_ev workItem \end{code} +Note [Shadowing of Implicit Parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example: + +f :: (?x :: Char) => Char +f = let ?x = 'a' in ?x + +The "let ?x = ..." generates an implication constraint of the form: + +?x :: Char => ?x :: Char + + +Furthermore, the signature for `f` also generates an implication +constraint, so we end up with the following nested implication: + +?x :: Char => (?x :: Char => ?x :: Char) + +Note that the wanted (?x :: Char) constraint may be solved in +two incompatible ways: either by using the parameter from the +signature, or by using the local definition. Our intention is +that the local definition should "shadow" the parameter of the +signature, and we implement this as follows: when we nest implications, +we remove any implicit parameters in the outer implication, that +have the same name as givens of the inner implication. + +Here is another variation of the example: + +f :: (?x :: Int) => Char +f = let ?x = 'x' in ?x + +This program should also be accepted: the two constraints `?x :: Int` +and `?x :: Char` never exist in the same context, so they don't get to +interact to cause failure. + Note [Superclasses and recursive dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Overlaps with Note [SUPERCLASS-LOOP 1] @@ -1039,7 +1010,7 @@ So our problem is this We may add the given in the inert set, along with its superclasses [assuming we don't fail because there is a matching instance, see - tryTopReact, given case ] + topReactionsStage, given case ] Inert: d0 :_g Foo t WorkList @@ -1297,48 +1268,36 @@ To achieve this required some refactoring of FunDeps.lhs (nicer now!). \begin{code} -rewriteWithFunDeps :: [Equation] - -> [Xi] - -> CtEvidence - -> TcS (Maybe ([Xi], [CtEvidence])) - -- Not quite a WantedEvVar unfortunately - -- Because our intention could be to make - -- it derived at the end of the day --- NB: The flavor of the returned EvVars will be decided by the caller +rewriteWithFunDeps :: [Equation] -> CtLoc -> TcS [Ct] +-- NB: The returned constraints are all Derived -- Post: returns no trivial equalities (identities) and all EvVars returned are fresh -rewriteWithFunDeps eqn_pred_locs xis fl - = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs - ; let fd_ev_pos :: [(Int,CtEvidence)] - fd_ev_pos = concat fd_ev_poss - rewritten_xis = rewriteDictParams fd_ev_pos xis - ; if null fd_ev_pos then return Nothing - else return (Just (rewritten_xis, map snd fd_ev_pos)) } - where wloc | Given { ctev_gloc = gl } <- fl - = setCtLocOrigin gl FunDepOrigin - | otherwise - = ctev_wloc fl - -instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,CtEvidence)] +rewriteWithFunDeps eqn_pred_locs loc + = do { fd_cts <- mapM (instFunDepEqn loc) eqn_pred_locs + ; return (concat fd_cts) } + +instFunDepEqn :: CtLoc -> Equation -> TcS [Ct] -- Post: Returns the position index as well as the corresponding FunDep equality -instFunDepEqn wl (FDEqn { fd_qtvs = tvs, fd_eqs = eqs - , fd_pred1 = d1, fd_pred2 = d2 }) +instFunDepEqn loc (FDEqn { fd_qtvs = tvs, fd_eqs = eqs + , fd_pred1 = d1, fd_pred2 = d2 }) = do { (subst, _) <- instFlexiTcS tvs -- Takes account of kind substitution ; foldM (do_one subst) [] eqs } where - do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 }) - = let sty1 = Type.substTy subst ty1 - sty2 = Type.substTy subst ty2 - in if eqType sty1 sty2 then return ievs -- Return no trivial equalities - else do { mb_eqv <- newDerived (push_ctx wl) (mkTcEqPred sty1 sty2) - ; case mb_eqv of - Just ctev -> return $ (i,ctev):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! - push_ctx :: WantedLoc -> WantedLoc - push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc - + der_loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc + + do_one subst ievs (FDEq { fd_ty_left = ty1, fd_ty_right = ty2 }) + | eqType sty1 sty2 + = return ievs -- Return no trivial equalities + | otherwise + = do { mb_eqv <- newDerived (mkTcEqPred sty1 sty2) + ; case mb_eqv of + Just ev -> return (mkNonCanonical der_loc ev : 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 mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc) @@ -1351,31 +1310,6 @@ mkEqnMsg (pred1,from1) (pred2,from2) tidy_env nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]), nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])] ; return (tidy_env, msg) } - -rewriteDictParams :: [(Int,CtEvidence)] -- A set of coercions : (pos, ty' ~ ty) - -> [Type] -- A sequence of types: tys - -> [Type] -rewriteDictParams param_eqs tys - = zipWith do_one tys [0..] - where - do_one :: Type -> Int -> Type - do_one ty n = case lookup n param_eqs of - Just wev -> get_fst_ty wev - Nothing -> ty - - get_fst_ty ctev - | Just (ty1, _) <- getEqPredTys_maybe (ctEvPred ctev) - = ty1 - | otherwise - = panic "rewriteDictParams: non equality fundep!?" - - -emitFDWorkAsDerived :: [CtEvidence] -- All Derived - -> SubGoalDepth -> TcS () -emitFDWorkAsDerived evlocs d - = updWorkListTcS $ appendWorkListEqs (map mk_fd_ct evlocs) - where - mk_fd_ct der_ev = CNonCanonical { cc_ev = der_ev, cc_depth = d } \end{code} @@ -1388,21 +1322,14 @@ emitFDWorkAsDerived evlocs d ********************************************************************************* \begin{code} - -topReactionsStage :: SimplifierStage -topReactionsStage workItem - = tryTopReact workItem - - -tryTopReact :: WorkItem -> TcS StopOrContinue -tryTopReact wi +topReactionsStage :: WorkItem -> TcS StopOrContinue +topReactionsStage wi = do { inerts <- getTcSInerts ; tir <- doTopReact inerts wi ; case tir of NoTopInt -> return (ContinueWith wi) SomeTopInt rule what_next - -> do { bumpStepCountTcS - ; traceFireTcS (cc_depth wi) $ + -> do { traceFireTcS wi $ vcat [ ptext (sLit "Top react:") <+> text rule , text "WorkItem =" <+> ppr wi ] ; return what_next } } @@ -1427,44 +1354,48 @@ doTopReact inerts workItem = do { traceTcS "doTopReact" (ppr workItem) ; case workItem of CDictCan { cc_ev = fl, cc_class = cls, cc_tyargs = xis - , cc_depth = d } + , cc_loc = d } -> doTopReactDict inerts workItem fl cls xis d CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = args - , cc_rhs = xi, cc_depth = d } - -> doTopReactFunEq fl tc args xi d + , cc_rhs = xi, cc_loc = d } + -> doTopReactFunEq workItem fl tc args xi d _ -> -- Any other work item does not react with any top-level equations return NoTopInt } -------------------- doTopReactDict :: InertSet -> WorkItem -> CtEvidence -> Class -> [Xi] - -> SubGoalDepth -> TcS TopInteractResult -doTopReactDict inerts workItem fl cls xis depth + -> CtLoc -> TcS TopInteractResult +doTopReactDict inerts workItem fl cls xis loc = do { instEnvs <- getInstEnvs - ; let fd_eqns = improveFromInstEnv instEnvs - (mkClassPred cls xis, arising_sdoc) + ; let pred = mkClassPred cls xis + fd_eqns = improveFromInstEnv instEnvs (pred, arising_sdoc) - ; m <- rewriteWithFunDeps fd_eqns xis fl - ; case m of - Just (_xis',fd_work) -> - do { emitFDWorkAsDerived fd_work depth - ; return SomeTopInt { tir_rule = "Dict/Top (fundeps)" - , tir_new_item = ContinueWith workItem } } - Nothing - | isWanted fl - -> do { lkup_inst_res <- matchClassInst inerts cls xis (getWantedLoc fl) - ; case lkup_inst_res of - GenInst wtvs ev_term -> - addToSolved fl >> doSolveFromInstance wtvs ev_term - NoInstance -> return NoTopInt } - | otherwise - -> return NoTopInt } + ; fd_work <- rewriteWithFunDeps fd_eqns loc + ; if not (null fd_work) then + do { updWorkListTcS (extendWorkListEqs fd_work) + ; return SomeTopInt { tir_rule = "Dict/Top (fundeps)" + , tir_new_item = ContinueWith workItem } } + else if not (isWanted fl) then + return NoTopInt + else do + + { solved_dicts <- getTcSInerts >>= (return . inert_solved_dicts) + ; case lookupSolvedDict solved_dicts pred of { + Just ev -> do { setEvBind dict_id (ctEvTerm ev); + ; return $ + SomeTopInt { tir_rule = "Dict/Top (cached)" + , tir_new_item = Stop } } ; + Nothing -> do + + { lkup_inst_res <- matchClassInst inerts cls xis loc + ; case lkup_inst_res of + GenInst wtvs ev_term -> do { addSolvedDict fl + ; doSolveFromInstance wtvs ev_term } + NoInstance -> return NoTopInt } } } } where - arising_sdoc - | isGiven fl = pprArisingAt $ getGivenLoc fl - | otherwise = pprArisingAt $ getWantedLoc fl - + arising_sdoc = pprArisingAt loc dict_id = ctEvId fl doSolveFromInstance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult @@ -1482,59 +1413,59 @@ doTopReactDict inerts workItem fl cls xis depth ppr dict_id ; setEvBind dict_id ev_term ; let mk_new_wanted ev - = CNonCanonical { cc_ev = ev - , cc_depth = depth + 1 } - ; updWorkListTcS (appendWorkListCt (map mk_new_wanted evs)) + = CNonCanonical { cc_ev = ev + , cc_loc = bumpCtLocDepth loc } + ; updWorkListTcS (extendWorkListCts (map mk_new_wanted evs)) ; return $ SomeTopInt { tir_rule = "Dict/Top (solved, more work)" , tir_new_item = Stop } } -------------------- -doTopReactFunEq :: CtEvidence -> TyCon -> [Xi] -> Xi - -> SubGoalDepth -> TcS TopInteractResult -doTopReactFunEq fl tc args xi d - = ASSERT (isSynFamilyTyCon tc) -- No associated data families have - -- reached that far - - -- First look in the cache of solved funeqs +doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi + -> CtLoc -> TcS TopInteractResult +doTopReactFunEq _ct fl fun_tc args xi loc + = 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 lookupFamHead fun_eq_cache (mkTyConApp tc args) of { - Just ctev -> ASSERT( not (isDerived ctev) ) - ASSERT( isEqPred (ctEvPred ctev) ) - succeed_with (evTermCoercion (ctEvTerm ctev)) - (snd (getEqPredTys (ctEvPred ctev))) ; - Nothing -> - - -- No cached solved, so look up in top-level instances - do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS] + ; case lookupFamHead fun_eq_cache fam_ty of { + Just (ctev, rhs_ty) + | ctEvFlavour ctev `canRewrite` ctEvFlavour fl + -> ASSERT( not (isDerived ctev) ) + succeed_with "Fun/Cache" (evTermCoercion (ctEvTerm ctev)) rhs_ty ; + _other -> + + -- Look up in top-level instances + do { match_res <- matchFam fun_tc args -- See Note [MATCHING-SYNONYMS] ; case match_res of { Nothing -> return NoTopInt ; Just (famInst, rep_tys) -> -- Found a top-level instance do { -- Add it to the solved goals - unless (isDerived fl) $ - do { addSolvedFunEq fl - ; addToSolved fl } + unless (isDerived fl) (addSolvedFunEq fam_ty fl xi) ; let coe_ax = famInstAxiom famInst - ; succeed_with (mkTcAxInstCo coe_ax rep_tys) + ; succeed_with "Fun/Top" (mkTcAxInstCo coe_ax rep_tys) (mkAxInstRHS coe_ax rep_tys) } } } } } where - succeed_with :: TcCoercion -> TcType -> TcS TopInteractResult - succeed_with coe rhs_ty + fam_ty = mkTyConApp fun_tc args + + succeed_with :: String -> TcCoercion -> TcType -> TcS TopInteractResult + succeed_with str co rhs_ty -- co :: fun_tc args ~ rhs_ty = do { ctevs <- xCtFlavor fl [mkTcEqPred rhs_ty xi] xev + ; traceTcS ("doTopReactFunEq " ++ str) (ppr ctevs) ; case ctevs of [ctev] -> updWorkListTcS $ extendWorkListEq $ CNonCanonical { cc_ev = ctev - , cc_depth = d+1 } + , cc_loc = bumpCtLocDepth loc } ctevs -> -- No subgoal (because it's cached) ASSERT( null ctevs) return () - ; return $ SomeTopInt { tir_rule = "Fun/Top" + ; return $ SomeTopInt { tir_rule = str , tir_new_item = Stop } } where - xdecomp x = [EvCoercion (mkTcSymCo coe `mkTcTransCo` evTermCoercion x)] - xcomp [x] = EvCoercion (coe `mkTcTransCo` evTermCoercion x) + xdecomp x = [EvCoercion (mkTcSymCo co `mkTcTransCo` evTermCoercion x)] + xcomp [x] = EvCoercion (co `mkTcTransCo` evTermCoercion x) xcomp _ = panic "No more goals!" xev = XEvTerm xcomp xdecomp \end{code} @@ -1743,7 +1674,7 @@ data LookupInstResult = NoInstance | GenInst [CtEvidence] EvTerm -matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult +matchClassInst :: InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult matchClassInst _ clas [ _, ty ] _ | className clas == singIClassName @@ -1786,7 +1717,7 @@ matchClassInst inerts clas tys loc ; if null theta then return (GenInst [] (EvDFunApp dfun_id tys [])) else do - { evc_vars <- instDFunConstraints loc theta + { evc_vars <- instDFunConstraints 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) @@ -1798,14 +1729,14 @@ matchClassInst inerts clas tys loc = lookupUFM (cts_given (inert_dicts $ inert_cans inerts)) clas `orElse` emptyCts - given_overlap :: TcsUntouchables -> Bool + given_overlap :: Untouchables -> Bool given_overlap untch = anyBag (matchable untch) givens_for_this_clas matchable untch (CDictCan { cc_class = clas_g, cc_tyargs = sys , cc_ev = fl }) | isGiven fl = ASSERT( clas_g == clas ) - case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv && + case tcUnifyTys (\tv -> if isTouchableMetaTyVar untch tv && tv `elemVarSet` tyVarsOfTypes tys then BindMe else Skolem) tys sys of -- We can't learn anything more about any variable at this point, so the only diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 67ed96731d..7a3db58e7c 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -25,10 +25,10 @@ module TcMType ( newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] newMetaKindVar, newMetaKindVars, mkKindSigVar, - mkTcTyVarName, + mkTcTyVarName, cloneMetaTyVar, newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, - isFilledMetaTyVar, isFlexiMetaTyVar, + newMetaDetails, isFilledMetaTyVar, isFlexiMetaTyVar, -------------------------------- -- Creating new evidence variables @@ -65,8 +65,8 @@ module TcMType ( zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, - zonkTcKind, defaultKindVarToStar, zonkCt, zonkCts, - zonkImplication, zonkEvVar, zonkWC, zonkId, + zonkTcKind, defaultKindVarToStar, + zonkEvVar, zonkWC, zonkId, zonkCt, zonkCts, zonkSkolemInfo, tcGetGlobalTyVars, ) where @@ -76,6 +76,7 @@ module TcMType ( -- friends: import TypeRep import TcType +import TcEvidence import Type import Kind import Class @@ -112,10 +113,18 @@ import Data.List ( (\\), partition, mapAccumL ) %************************************************************************ \begin{code} +mkKindName :: Unique -> Name +mkKindName unique = mkSystemName unique kind_var_occ + +kind_var_occ :: OccName -- Just one for all MetaKindVars + -- They may be jiggled by tidying +kind_var_occ = mkOccName tvName "k" + newMetaKindVar :: TcM TcKind -newMetaKindVar = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi - ; return (mkTyVarTy (mkMetaKindVar uniq ref)) } +newMetaKindVar = do { uniq <- newUnique + ; details <- newMetaDetails TauTv + ; let kv = mkTcTyVar (mkKindName uniq) superKind details + ; return (mkTyVarTy kv) } newMetaKindVars :: Int -> TcM [TcKind] newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ()) @@ -146,17 +155,17 @@ newWantedEvVars theta = mapM newWantedEvVar theta newEvVar :: TcPredType -> TcM EvVar -- Creates new *rigid* variables for predicates -newEvVar ty = do { name <- newName (predTypeOccName ty) +newEvVar ty = do { name <- newSysName (predTypeOccName ty) ; return (mkLocalId name ty) } newEq :: TcType -> TcType -> TcM EvVar newEq ty1 ty2 - = do { name <- newName (mkVarOccFS (fsLit "cobox")) + = do { name <- newSysName (mkVarOccFS (fsLit "cobox")) ; return (mkLocalId name (mkTcEqPred ty1 ty2)) } newDict :: Class -> [TcType] -> TcM DictId newDict cls tys - = do { name <- newName (mkDictOcc (getOccName cls)) + = do { name <- newSysName (mkDictOcc (getOccName cls)) ; return (mkLocalId name (mkClassPred cls tys)) } predTypeOccName :: PredType -> OccName @@ -266,12 +275,18 @@ tcInstSigTyVar subst tv newSigTyVar :: Name -> Kind -> TcM TcTyVar newSigTyVar name kind - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi + = 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 - ; return (mkTcTyVar name' kind (MetaTv SigTv ref)) } + ; 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 }) } \end{code} Note [Kind substitution when instantiating] @@ -300,14 +315,24 @@ instead of the buggous newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar -- Make a new meta tyvar out of thin air newMetaTyVar meta_info kind - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi + = do { uniq <- newUnique ; let name = mkTcTyVarName uniq s s = case meta_info of TauTv -> fsLit "t" - TcsTv -> fsLit "u" SigTv -> fsLit "a" - ; return (mkTcTyVar name kind (MetaTv meta_info ref)) } + ; details <- newMetaDetails meta_info + ; return (mkTcTyVar name kind details) } + +cloneMetaTyVar :: TcTyVar -> TcM TcTyVar +cloneMetaTyVar tv + = ASSERT( isTcTyVar tv ) + do { uniq <- newUnique + ; ref <- newMutVar Flexi + ; let name' = setNameUnique (tyVarName tv) uniq + details' = case tcTyVarDetails tv of + details@(MetaTv {}) -> details { mtv_ref = ref } + _ -> pprPanic "cloneMetaTyVar" (ppr tv) + ; return (mkTcTyVar name' (tyVarKind tv) details') } mkTcTyVarName :: Unique -> FastString -> Name -- Make sure that fresh TcTyVar names finish with a digit @@ -323,7 +348,7 @@ isFilledMetaTyVar :: TyVar -> TcM Bool -- True of a filled-in (Indirect) meta type variable isFilledMetaTyVar tv | not (isTcTyVar tv) = return False - | MetaTv _ ref <- tcTyVarDetails tv + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv = do { details <- readMutVar ref ; return (isIndirect details) } | otherwise = return False @@ -332,7 +357,7 @@ isFlexiMetaTyVar :: TyVar -> TcM Bool -- True of a un-filled-in (Flexi) meta type variable isFlexiMetaTyVar tv | not (isTcTyVar tv) = return False - | MetaTv _ ref <- tcTyVarDetails tv + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv = do { details <- readMutVar ref ; return (isFlexi details) } | otherwise = return False @@ -351,7 +376,7 @@ writeMetaTyVar tyvar ty = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar ) return () - | MetaTv _ ref <- tcTyVarDetails tyvar + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar = writeMetaTyVarRef tyvar ref ty | otherwise @@ -433,11 +458,11 @@ 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. tcInstTyVarX subst tyvar - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi + = do { uniq <- newUnique + ; details <- newMetaDetails TauTv ; let name = mkSystemName uniq (getOccName tyvar) kind = substTy subst (tyVarKind tyvar) - new_tv = mkTcTyVar name kind (MetaTv TauTv ref) + new_tv = mkTcTyVar name kind details ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } \end{code} @@ -548,7 +573,7 @@ zonkQuantifiedTyVar tv -- It might be a skolem type variable, -- for example from a user type signature - MetaTv _ ref -> + MetaTv { mtv_ref = ref } -> do when debugIsOn $ do -- [Sept 04] Check for non-empty. -- See note [Silly Type Synonym] @@ -593,60 +618,148 @@ skolemiseSigTv tv \begin{code} zonkImplication :: Implication -> TcM Implication -zonkImplication implic@(Implic { ic_skols = skols - , ic_given = given +zonkImplication implic@(Implic { ic_untch = untch + , ic_binds = binds_var + , ic_skols = skols + , ic_given = given , ic_wanted = wanted - , ic_loc = loc }) + , ic_info = info }) = do { skols' <- mapM zonkTcTyVarBndr skols -- Need to zonk their kinds! -- as Trac #7230 showed ; given' <- mapM zonkEvVar given - ; loc' <- zonkGivenLoc loc - ; wanted' <- zonkWC wanted + ; info' <- zonkSkolemInfo info + ; wanted' <- zonkWCRec binds_var untch wanted ; return (implic { ic_skols = skols' , ic_given = given' + , ic_fsks = [] -- Zonking removes all FlatSkol tyvars , ic_wanted = wanted' - , ic_loc = loc' }) } + , ic_info = info' }) } zonkEvVar :: EvVar -> TcM EvVar zonkEvVar var = do { ty' <- zonkTcType (varType var) ; return (setVarType var ty') } -zonkWC :: WantedConstraints -> TcM WantedConstraints -zonkWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) - = do { flat' <- mapBagM zonkCt flat +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 } + +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 ; implic' <- mapBagM zonkImplication implic - ; insol' <- mapBagM zonkCt insol + ; insol' <- zonkCts insol -- No need to do the more elaborate zonkFlats thing ; return (WC { wc_flat = flat', wc_impl = implic', wc_insol = insol' }) } -zonkCt :: Ct -> TcM Ct --- Zonking a Ct conservatively gives back a CNonCanonical -zonkCt ct - = do { fl' <- zonkCtEvidence (cc_ev ct) - ; return $ - CNonCanonical { cc_ev = fl' - , cc_depth = cc_depth ct } } +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 + , typeKind ty_lhs `tcIsSubKind` tyVarKind tv + , not (tv `elemVarSet` tyVarsOfType ty_lhs) +-- , Just ty_lhs' <- occurCheck tv ty_lhs + = ASSERT2( isWantedCt orig_ct, ppr orig_ct ) + ASSERT2( case tcSplitTyConApp_maybe ty_lhs of { Just (tc,_) -> isSynFamilyTyCon tc; _ -> False }, ppr orig_ct ) + do { writeMetaTyVar tv ty_lhs + ; let evterm = EvCoercion (mkTcReflCo ty_lhs) + evvar = ctev_evar (cc_ev zct) + ; 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 analgoy 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 +zonkCt :: Ct -> TcM Ct +zonkCt ct@(CHoleCan { cc_ev = ev }) + = do { ev' <- zonkCtEvidence ev + ; return $ ct { cc_ev = ev' } } +zonkCt ct + = do { fl' <- zonkCtEvidence (cc_ev ct) + ; return (CNonCanonical { cc_ev = fl' + , cc_loc = cc_loc ct }) } + zonkCtEvidence :: CtEvidence -> TcM CtEvidence -zonkCtEvidence ctev@(Given { ctev_gloc = loc, ctev_pred = pred }) - = do { loc' <- zonkGivenLoc loc - ; pred' <- zonkTcType pred - ; return (ctev { ctev_gloc = loc', ctev_pred = pred'}) } -zonkCtEvidence ctev@(Wanted { ctev_pred = pred }) +zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) + = do { pred' <- zonkTcType pred + ; return (ctev { ctev_pred = pred'}) } +zonkCtEvidence ctev@(CtWanted { ctev_pred = pred }) = do { pred' <- zonkTcType pred ; return (ctev { ctev_pred = pred' }) } -zonkCtEvidence ctev@(Derived { ctev_pred = pred }) +zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) = do { pred' <- zonkTcType pred ; return (ctev { ctev_pred = pred' }) } -zonkGivenLoc :: GivenLoc -> TcM GivenLoc --- GivenLocs may have unification variables inside them! -zonkGivenLoc (CtLoc skol_info span ctxt) - = do { skol_info' <- zonkSkolemInfo skol_info - ; return (CtLoc skol_info' span ctxt) } - zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo zonkSkolemInfo (SigSkol cx ty) = do { ty' <- zonkTcType ty ; return (SigSkol cx ty') } @@ -789,10 +902,11 @@ zonkTcTyVar tv SkolemTv {} -> zonk_kind_and_return RuntimeUnk {} -> zonk_kind_and_return FlatSkol ty -> zonkTcType ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_kind_and_return - Indirect ty -> zonkTcType ty } + MetaTv { mtv_ref = ref } + -> do { cts <- readMutVar ref + ; case cts of + Flexi -> zonk_kind_and_return + Indirect ty -> zonkTcType ty } where zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv ; return (TyVarTy z_tv) } diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index acc20649c0..5a00470caf 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -13,10 +13,10 @@ TcMatches: Typecheck some @Matches@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details -module TcMatches ( tcMatchesFun, tcGRHSsPat, tcGRHS, tcMatchesCase, - tcMatchLambda, TcMatchCtxt(..), TcStmtChecker, - tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, - tcDoStmt, tcGuardStmt +module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, + TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, + tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, + tcDoStmt, tcGuardStmt ) where import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId, @@ -69,9 +69,10 @@ See Note [sig_tau may be polymorphic] in TcPat. \begin{code} tcMatchesFun :: Name -> Bool - -> MatchGroup Name - -> TcSigmaType -- Expected type of function - -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body + -> MatchGroup Name (LHsExpr Name) + -> TcSigmaType -- Expected type of function + -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) + -- Returns type of body tcMatchesFun fun_name inf matches exp_ty = do { -- Check that they all have the same no of arguments -- Location is in the monad, set the caller so that @@ -99,11 +100,12 @@ tcMatchesFun fun_name inf matches exp_ty parser guarantees that each equation has exactly one argument. \begin{code} -tcMatchesCase :: TcMatchCtxt -- Case context - -> TcRhoType -- Type of scrutinee - -> MatchGroup Name -- The case alternatives - -> TcRhoType -- Type of whole case expressions - -> TcM (MatchGroup TcId) -- Translated alternatives +tcMatchesCase :: (Outputable (body Name)) => + TcMatchCtxt body -- Case context + -> TcRhoType -- Type of scrutinee + -> MatchGroup Name (Located (body Name)) -- The case alternatives + -> TcRhoType -- Type of whole case expressions + -> TcM (MatchGroup TcId (Located (body TcId))) -- Translated alternatives tcMatchesCase ctxt scrut_ty matches res_ty | isEmptyMatchGroup matches -- Allow empty case expressions @@ -112,7 +114,8 @@ tcMatchesCase ctxt scrut_ty matches res_ty | otherwise = tcMatches ctxt [scrut_ty] res_ty matches -tcMatchLambda :: MatchGroup Name -> TcRhoType -> TcM (HsWrapper, MatchGroup TcId) +tcMatchLambda :: MatchGroup Name (LHsExpr Name) -> TcRhoType + -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) tcMatchLambda match res_ty = matchFunTys herald n_pats res_ty $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty match @@ -130,7 +133,8 @@ tcMatchLambda match res_ty @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. \begin{code} -tcGRHSsPat :: GRHSs Name -> TcRhoType -> TcM (GRHSs TcId) +tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType + -> TcM (GRHSs TcId (LHsExpr TcId)) -- Used for pattern bindings tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty where @@ -163,18 +167,18 @@ matchFunTys herald arity res_ty thing_inside %************************************************************************ \begin{code} -tcMatches :: TcMatchCtxt - -> [TcSigmaType] -- Expected pattern types - -> TcRhoType -- Expected result-type of the Match. - -> MatchGroup Name - -> TcM (MatchGroup TcId) - -data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module - = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is - mc_body :: LHsExpr Name -- Type checker for a body of +tcMatches :: (Outputable (body Name)) => TcMatchCtxt body + -> [TcSigmaType] -- Expected pattern types + -> TcRhoType -- Expected result-type of the Match. + -> MatchGroup Name (Located (body Name)) + -> TcM (MatchGroup TcId (Located (body TcId))) + +data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module + = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is + mc_body :: Located (body Name) -- Type checker for a body of -- an alternative - -> TcRhoType - -> TcM (LHsExpr TcId) } + -> TcRhoType + -> TcM (Located (body TcId)) } tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _) = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in @@ -182,11 +186,11 @@ tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _) ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) } ------------- -tcMatch :: TcMatchCtxt - -> [TcSigmaType] -- Expected pattern types - -> TcRhoType -- Expected result-type of the Match. - -> LMatch Name - -> TcM (LMatch TcId) +tcMatch :: (Outputable (body Name)) => TcMatchCtxt body + -> [TcSigmaType] -- Expected pattern types + -> TcRhoType -- Expected result-type of the Match. + -> LMatch Name (Located (body Name)) + -> TcM (LMatch TcId (Located (body TcId))) tcMatch ctxt pat_tys rhs_ty match = wrapLocM (tc_match ctxt pat_tys rhs_ty) match @@ -212,8 +216,8 @@ tcMatch ctxt pat_tys rhs_ty match m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside ------------- -tcGRHSs :: TcMatchCtxt -> GRHSs Name -> TcRhoType - -> TcM (GRHSs TcId) +tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> TcRhoType + -> TcM (GRHSs TcId (Located (body TcId))) -- Notice that we pass in the full res_ty, so that we get -- good inference from simple things like @@ -228,7 +232,8 @@ tcGRHSs ctxt (GRHSs grhss binds) res_ty ; return (GRHSs grhss' binds') } ------------- -tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId) +tcGRHS :: TcMatchCtxt body -> TcRhoType -> GRHS Name (Located (body Name)) + -> TcM (GRHS TcId (Located (body TcId))) tcGRHS ctxt res_ty (GRHS guards rhs) = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ @@ -247,7 +252,7 @@ tcGRHS ctxt res_ty (GRHS guards rhs) \begin{code} tcDoStmts :: HsStmtContext Name - -> [LStmt Name] + -> [LStmt Name (LHsExpr Name)] -> TcRhoType -> TcM (HsExpr TcId) -- Returns a HsDo tcDoStmts ListComp stmts res_ty @@ -292,29 +297,33 @@ tcBody body res_ty %************************************************************************ \begin{code} -type TcStmtChecker + +type TcExprStmtChecker = TcStmtChecker HsExpr +type TcCmdStmtChecker = TcStmtChecker HsCmd + +type TcStmtChecker body = forall thing. HsStmtContext Name - -> Stmt Name - -> TcRhoType -- Result type for comprehension - -> (TcRhoType -> TcM thing) -- Checker for what follows the stmt - -> TcM (Stmt TcId, thing) - -tcStmts :: HsStmtContext Name - -> TcStmtChecker -- NB: higher-rank type - -> [LStmt Name] - -> TcRhoType - -> TcM [LStmt TcId] + -> Stmt Name (Located (body Name)) + -> TcRhoType -- Result type for comprehension + -> (TcRhoType -> TcM thing) -- Checker for what follows the stmt + -> TcM (Stmt TcId (Located (body TcId)), thing) + +tcStmts :: (Outputable (body Name)) => HsStmtContext Name + -> TcStmtChecker body -- NB: higher-rank type + -> [LStmt Name (Located (body Name))] + -> TcRhoType + -> TcM [LStmt TcId (Located (body TcId))] tcStmts ctxt stmt_chk stmts res_ty = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ const (return ()) ; return stmts' } -tcStmtsAndThen :: HsStmtContext Name - -> TcStmtChecker -- NB: higher-rank type - -> [LStmt Name] - -> TcRhoType - -> (TcRhoType -> TcM thing) - -> TcM ([LStmt TcId], thing) +tcStmtsAndThen :: (Outputable (body Name)) => HsStmtContext Name + -> TcStmtChecker body -- NB: higher-rank type + -> [LStmt Name (Located (body Name))] + -> TcRhoType + -> (TcRhoType -> TcM thing) + -> TcM ([LStmt TcId (Located (body TcId))], thing) -- Note the higher-rank type. stmt_chk is applied at different -- types in the equations for tcStmts @@ -344,11 +353,11 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside -- Pattern guards --------------------------------------------------- -tcGuardStmt :: TcStmtChecker -tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside +tcGuardStmt :: TcExprStmtChecker +tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside = do { guard' <- tcMonoExpr guard boolTy ; thing <- thing_inside res_ty - ; return (ExprStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) } + ; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) } tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already @@ -374,8 +383,8 @@ tcGuardStmt _ stmt _ _ -- coercion matching stuff in them. It's hard to avoid the -- potential for non-trivial coercions in tcMcStmt -tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) - -> TcStmtChecker +tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) + -> TcExprStmtChecker tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside = do { body' <- tcMonoExprNC body elt_ty @@ -391,10 +400,10 @@ tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } -- A boolean guard -tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside +tcLcStmt _ _ (BodyStmt rhs _ _ _) elt_ty thing_inside = do { rhs' <- tcMonoExpr rhs boolTy ; thing <- thing_inside elt_ty - ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } + ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } -- ParStmt: See notes with tcMcStmt tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _) elt_ty thing_inside @@ -482,7 +491,7 @@ tcLcStmt _ _ stmt _ _ -- (supports rebindable syntax) --------------------------------------------------- -tcMcStmt :: TcStmtChecker +tcMcStmt :: TcExprStmtChecker tcMcStmt _ (LastStmt body return_op) res_ty thing_inside = do { a_ty <- newFlexiTyVarTy liftedTypeKind @@ -522,7 +531,7 @@ tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside -- -- [ body | stmts, expr ] -> expr :: m Bool -- -tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside +tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside = do { -- Deal with rebindable syntax: -- guard_op :: test_ty -> rhs_ty -- then_op :: rhs_ty -> new_res_ty -> res_ty @@ -536,7 +545,7 @@ tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside ; then_op' <- tcSyntaxOp MCompOrigin then_op (mkFunTys [rhs_ty, new_res_ty] res_ty) ; thing <- thing_inside new_res_ty - ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) } + ; return (BodyStmt rhs' then_op' guard_op' rhs_ty, thing) } -- Grouping statements -- @@ -731,7 +740,7 @@ tcMcStmt _ stmt _ _ -- (supports rebindable syntax) --------------------------------------------------- -tcDoStmt :: TcStmtChecker +tcDoStmt :: TcExprStmtChecker tcDoStmt _ (LastStmt body _) res_ty thing_inside = do { body' <- tcMonoExprNC body res_ty @@ -767,7 +776,7 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } -tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside +tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside = do { -- Deal with rebindable syntax; -- (>>) :: rhs_ty -> new_res_ty -> res_ty -- See also Note [Treat rebindable syntax first] @@ -778,7 +787,7 @@ tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside ; rhs' <- tcMonoExprNC rhs rhs_ty ; thing <- thing_inside new_res_ty - ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) } + ; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) } tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names , recS_rec_ids = rec_names, recS_ret_fn = ret_op @@ -845,7 +854,7 @@ the expected/inferred stuff is back to front (see Trac #3613). number of args are used in each equation. \begin{code} -checkArgs :: Name -> MatchGroup Name -> TcM () +checkArgs :: Name -> MatchGroup Name body -> TcM () checkArgs fun (MatchGroup (match1:matches) _) | null bad_matches = return () | otherwise @@ -857,7 +866,7 @@ checkArgs fun (MatchGroup (match1:matches) _) n_args1 = args_in_match match1 bad_matches = [m | m <- matches, args_in_match m /= n_args1] - args_in_match :: LMatch Name -> Int + args_in_match :: LMatch Name body -> Int args_in_match (L _ (Match pats _ _)) = length pats checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty \end{code} diff --git a/compiler/typecheck/TcMatches.lhs-boot b/compiler/typecheck/TcMatches.lhs-boot index 8c421da6da..1fe05ec1e5 100644 --- a/compiler/typecheck/TcMatches.lhs-boot +++ b/compiler/typecheck/TcMatches.lhs-boot @@ -1,17 +1,18 @@ \begin{code} module TcMatches where -import HsSyn ( GRHSs, MatchGroup ) +import HsSyn ( GRHSs, MatchGroup, LHsExpr ) import TcEvidence( HsWrapper ) import Name ( Name ) import TcType ( TcRhoType ) import TcRnTypes( TcM, TcId ) +--import SrcLoc ( Located ) -tcGRHSsPat :: GRHSs Name +tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType - -> TcM (GRHSs TcId) + -> TcM (GRHSs TcId (LHsExpr TcId)) tcMatchesFun :: Name -> Bool - -> MatchGroup Name + -> MatchGroup Name (LHsExpr Name) -> TcRhoType - -> TcM (HsWrapper, MatchGroup TcId) + -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 0d00fb68c2..6430c95862 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -63,7 +63,6 @@ import CoreSyn import ErrUtils import Id import VarEnv -import Var import Module import UniqFM import Name @@ -726,15 +725,12 @@ checkBootTyCon tc1 tc2 | Just c1 <- tyConClass_maybe tc1 , Just c2 <- tyConClass_maybe tc2 - = let - (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) + , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1) = classExtraBigSig c1 - (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) + (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) = classExtraBigSig c2 - - env0 = mkRnEnv2 emptyInScopeSet - env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2 - + , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 + = let eqSig (id1, def_meth1) (id2, def_meth2) = idName id1 == idName id2 && eqTypeX env op_ty1 op_ty2 && @@ -751,18 +747,15 @@ checkBootTyCon tc1 tc2 -- Ignore the location of the defaults eqATDef (ATD tvs1 ty_pats1 ty1 _loc1) (ATD tvs2 ty_pats2 ty2 _loc2) - = eqListBy same_kind tvs1 tvs2 && - eqListBy (eqTypeX env) ty_pats1 ty_pats2 && + | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2 + = eqListBy (eqTypeX env) ty_pats1 ty_pats2 && eqTypeX env ty1 ty2 - where env = rnBndrs2 env0 tvs1 tvs2 + | otherwise = False eqFD (as1,bs1) (as2,bs2) = eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) - - same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2) in - eqListBy same_kind clas_tyvars1 clas_tyvars2 && -- Checks kind of class eqListBy eqFD clas_fds1 clas_fds2 && (null sc_theta1 && null op_stuff1 && null ats1 @@ -771,24 +764,22 @@ checkBootTyCon tc1 tc2 eqListBy eqSig op_stuff1 op_stuff2 && eqListBy eqAT ats1 ats2) - | isSynTyCon tc1 && isSynTyCon tc2 + | Just syn_rhs1 <- synTyConRhs_maybe tc1 + , Just syn_rhs2 <- synTyConRhs_maybe tc2 + , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = ASSERT(tc1 == tc2) - let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2 - env = rnBndrs2 env0 tvs1 tvs2 - - eqSynRhs SynFamilyTyCon SynFamilyTyCon - = True + let eqSynRhs (SynFamilyTyCon o1 i1) (SynFamilyTyCon o2 i2) + = o1==o2 && i1==i2 eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) = eqTypeX env t1 t2 eqSynRhs _ _ = False in - equalLength tvs1 tvs2 && - eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2) + eqSynRhs syn_rhs1 syn_rhs2 | isAlgTyCon tc1 && isAlgTyCon tc2 + , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = ASSERT(tc1 == tc2) - eqKind (tyConKind tc1) (tyConKind tc2) && - eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) && + eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) | isForeignTyCon tc1 && isForeignTyCon tc2 @@ -797,24 +788,25 @@ checkBootTyCon tc1 tc2 | otherwise = False where - env0 = mkRnEnv2 emptyInScopeSet - - eqAlgRhs (AbstractTyCon dis1) rhs2 - | dis1 = isDistinctAlgRhs rhs2 --Check compatibility - | otherwise = True - eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True - eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = - eqListBy eqCon (data_cons tc1) (data_cons tc2) - eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} = - eqCon (data_con tc1) (data_con tc2) - eqAlgRhs _ _ = False - - eqCon c1 c2 - = dataConName c1 == dataConName c2 - && dataConIsInfix c1 == dataConIsInfix c2 - && dataConStrictMarks c1 == dataConStrictMarks c2 - && dataConFieldLabels c1 == dataConFieldLabels c2 - && eqType (dataConUserType c1) (dataConUserType c2) + eqAlgRhs (AbstractTyCon dis1) rhs2 + | dis1 = isDistinctAlgRhs rhs2 --Check compatibility + | otherwise = True + eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True + eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = + eqListBy eqCon (data_cons tc1) (data_cons tc2) + eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} = + eqCon (data_con tc1) (data_con tc2) + eqAlgRhs _ _ = False + + eqCon c1 c2 + = dataConName c1 == dataConName c2 + && dataConIsInfix c1 == dataConIsInfix c2 + && dataConStrictMarks c1 == dataConStrictMarks c2 + && dataConFieldLabels c1 == dataConFieldLabels c2 + && eqType (dataConUserType c1) (dataConUserType c2) + +emptyRnEnv2 :: RnEnv2 +emptyRnEnv2 = mkRnEnv2 emptyInScopeSet ---------------- missingBootThing :: Name -> String -> SDoc @@ -1209,7 +1201,7 @@ setInteractiveContext hsc_env icxt thing_inside -- -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). -tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName +tcRnStmt :: HscEnv -> InteractiveContext -> GhciLStmt RdrName -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv)) tcRnStmt hsc_env ictxt rdr_stmt = initTcPrintErrors hsc_env iNTERACTIVE $ @@ -1320,10 +1312,10 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p -- for more details. We do this lifting by trying different ways ('plans') of -- lifting the code into the IO monad and type checking each plan until one -- succeeds. -tcUserStmt :: LStmt RdrName -> TcM (PlanResult, FixityEnv) +tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv) -- An expression typed at the prompt is treated very specially -tcUserStmt (L loc (ExprStmt expr _ _ _)) +tcUserStmt (L loc (BodyStmt expr _ _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! ; ghciStep <- getGhciStepIO @@ -1347,7 +1339,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) (HsVar bindIOName) noSyntaxExpr -- [; print it] - print_it = L loc $ ExprStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) + print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) (HsVar thenIOName) noSyntaxExpr placeHolderType -- The plans are: @@ -1383,7 +1375,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) tcUserStmt rdr_stmt@(L loc _) = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ - rnStmts GhciStmt [rdr_stmt] $ \_ -> do + rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do fix_env <- getFixityEnv return (fix_env, emptyFVs) -- Don't try to typecheck if the renamer fails! @@ -1415,19 +1407,19 @@ tcUserStmt rdr_stmt@(L loc _) ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } where - print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) + print_v = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) (HsVar thenIOName) noSyntaxExpr placeHolderType -- | Typecheck the statements given and then return the results of the -- statement in the form 'IO [()]'. -tcGhciStmts :: [LStmt Name] -> TcM PlanResult +tcGhciStmts :: [GhciLStmt Name] -> TcM PlanResult tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; ret_id <- tcLookupId returnIOName ; -- return @ IO let { ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; + tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts io_ret_ty ; names = collectLStmtsBinders stmts ; } ; @@ -1463,7 +1455,7 @@ tcGhciStmts stmts stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] } ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmt stmts io_ret_ty)) + noLoc (HsDo GhciStmtCtxt stmts io_ret_ty)) } -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) @@ -1522,14 +1514,14 @@ tcRnExpr hsc_env ictxt 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), untch), lie) <- captureConstraints $ - captureUntouchables (tcInferRho rn_expr) ; + ((_tc_expr, res_ty), lie) <- captureConstraints $ + tcInferRho rn_expr ; ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ {-# SCC "simplifyInfer" #-} simplifyInfer True {- Free vars are closed -} False {- No MR for now -} [(fresh_it, res_ty)] - (untch,lie) ; + lie ; _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 3cfc7044c6..68301f7972 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -42,7 +42,6 @@ import NameSet import Bag import Outputable import UniqSupply -import Unique import UniqFM import DynFlags import Maybes @@ -78,7 +77,6 @@ initTc :: HscEnv initTc hsc_env hsc_src keep_rn_syntax mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; - meta_var <- newIORef initTyVarUnique ; tvs_var <- newIORef emptyVarSet ; keep_var <- newIORef emptyNameSet ; used_rdr_var <- newIORef Set.empty ; @@ -148,11 +146,11 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcl_th_ctxt = topStage, tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, + tcl_bndrs = [], tcl_tidy = emptyTidyEnv, tcl_tyvars = tvs_var, tcl_lie = lie_var, - tcl_meta = meta_var, - tcl_untch = initTyVarUnique + tcl_untch = noUntouchables } ; } ; @@ -345,16 +343,6 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) %************************************************************************ \begin{code} -newMetaUnique :: TcM Unique --- The uniques for TcMetaTyVars are allocated specially --- in guaranteed linear order, starting at zero for each module -newMetaUnique - = do { env <- getLclEnv - ; let meta_var = tcl_meta env - ; uniq <- readMutVar meta_var - ; writeMutVar meta_var (incrUnique uniq) - ; return uniq } - newUnique :: TcRnIf gbl lcl Unique newUnique = do { env <- getEnv ; @@ -379,15 +367,8 @@ newUniqueSupply writeMutVar u_var us1 ; return us2 }}} -newLocalName :: Name -> TcRnIf gbl lcl Name -newLocalName name -- Make a clone - = do { uniq <- newUnique - ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) } - -newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] -newSysLocalIds fs tys - = do { us <- newUniqueSupply - ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } +newLocalName :: Name -> TcM Name +newLocalName name = newName (nameOccName name) newName :: OccName -> TcM Name newName occ @@ -395,6 +376,16 @@ newName occ ; loc <- getSrcSpanM ; return (mkInternalName uniq occ loc) } +newSysName :: OccName -> TcM Name +newSysName occ + = do { uniq <- newUnique + ; return (mkSystemName uniq occ) } + +newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] +newSysLocalIds fs tys + = do { us <- newUniqueSupply + ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } + instance MonadUnique (IOEnv (Env gbl lcl)) where getUniqueM = newUnique getUniqueSupplyM = newUniqueSupply @@ -829,14 +820,18 @@ updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> popErrCtxt :: TcM a -> TcM a popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) -getCtLoc :: orig -> TcM (CtLoc orig) +getCtLoc :: CtOrigin -> TcM CtLoc getCtLoc origin - = do { loc <- getSrcSpanM ; env <- getLclEnv ; - return (CtLoc origin loc (tcl_ctxt env)) } - -setCtLoc :: CtLoc orig -> TcM a -> TcM a -setCtLoc (CtLoc _ src_loc ctxt) thing_inside - = setSrcSpan src_loc (setErrCtxt ctxt thing_inside) + = do { env <- getLclEnv + ; return (CtLoc { ctl_origin = origin, ctl_env = env, ctl_depth = 0 }) } + +setCtLoc :: CtLoc -> TcM a -> TcM a +-- Set the SrcSpan and error context from the CtLoc +setCtLoc (CtLoc { ctl_env = lcl }) thing_inside + = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl + , tcl_bndrs = tcl_bndrs lcl + , tcl_ctxt = tcl_ctxt lcl }) + thing_inside \end{code} %************************************************************************ @@ -1037,6 +1032,13 @@ emitImplications ct = do { lie_var <- getConstraintVar ; updTcRef lie_var (`addImplics` ct) } +emitInsoluble :: Ct -> TcM () +emitInsoluble ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addInsols` unitBag ct) ; + v <- readTcRef lie_var ; + traceTc "emitInsoluble" (ppr v) } + captureConstraints :: TcM a -> TcM (a, WantedConstraints) -- (captureConstraints m) runs m, and returns the type constraints it generates captureConstraints thing_inside @@ -1049,20 +1051,27 @@ captureConstraints thing_inside captureUntouchables :: TcM a -> TcM (a, Untouchables) captureUntouchables thing_inside = do { env <- getLclEnv - ; low_meta <- readTcRef (tcl_meta env) - ; res <- setLclEnv (env { tcl_untch = low_meta }) + ; let untch' = pushUntouchables (tcl_untch env) + ; res <- setLclEnv (env { tcl_untch = untch' }) thing_inside - ; high_meta <- readTcRef (tcl_meta env) - ; return (res, TouchableRange low_meta high_meta) } + ; return (res, untch') } + +getUntouchables :: TcM Untouchables +getUntouchables = do { env <- getLclEnv + ; return (tcl_untch env) } + +setUntouchables :: Untouchables -> TcM a -> TcM a +setUntouchables untch thing_inside + = updLclEnv (\env -> env { tcl_untch = untch }) thing_inside -isUntouchable :: TcTyVar -> TcM Bool -isUntouchable tv +isTouchableTcM :: TcTyVar -> TcM Bool +isTouchableTcM tv -- Kind variables are always touchable | isSuperKind (tyVarKind tv) = return False | otherwise = do { env <- getLclEnv - ; return (varUnique tv < tcl_untch env) } + ; return (isTouchableMetaTyVar (tcl_untch env) tv) } getLclTypeEnv :: TcM TcTypeEnv getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 035833c9a6..aa5dec9bd2 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -38,7 +38,7 @@ module TcRnTypes( WhereFrom(..), mkModDeps, -- Typechecker types - TcTypeEnv, TcTyThing(..), PromotionErr(..), + TcTypeEnv, TcIdBinder(..), TcTyThing(..), PromotionErr(..), pprTcTyThingCategory, pprPECategory, -- Template Haskell @@ -48,33 +48,33 @@ module TcRnTypes( -- Arrows ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, - -- Constraints - Untouchables(..), inTouchableRange, isNoUntouchables, - -- Canonical constraints - Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, keepWanted, + Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, dropDerivedWC, singleCt, extendCts, isEmptyCts, isCTyEqCan, isCFunEqCan, isCDictCan_Maybe, isCFunEqCan_Maybe, isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, - isGivenCt, - ctWantedLoc, ctEvidence, - SubGoalDepth, mkNonCanonical, ctPred, ctEvPred, ctEvTerm, ctEvId, + isGivenCt, isHoleCt, + ctEvidence, + SubGoalDepth, mkNonCanonical, mkNonCanonicalCt, + ctPred, ctEvPred, ctEvTerm, ctEvId, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, - andWC, addFlats, addImplics, mkFlatWC, + andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols, Implication(..), - CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin, - CtOrigin(..), EqOrigin(..), - WantedLoc, GivenLoc, pushErrCtxt, - pushErrCtxtSameOrigin, + CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin, + ctLocDepth, bumpCtLocDepth, + setCtLocOrigin, + CtOrigin(..), + pushErrCtxt, pushErrCtxtSameOrigin, SkolemInfo(..), - CtEvidence(..), pprFlavorArising, + CtEvidence(..), mkGivenLoc, isWanted, isGiven, - isDerived, getWantedLoc, getGivenLoc, canSolve, canRewrite, + isDerived, canSolve, canRewrite, + CtFlavour(..), ctEvFlavour, ctFlavour, -- Pretty printing pprEvVarTheta, pprWantedsWithLocs, @@ -113,17 +113,14 @@ import VarSet import ErrUtils import UniqFM import UniqSupply -import Unique import BasicTypes import Bag import DynFlags import Outputable import ListSetOps import FastString -import Util import Data.Set (Set) - \end{code} @@ -410,12 +407,11 @@ Why? Because they are now Ids not TcIds. This final GlobalEnv is data TcLclEnv -- Changes as we move inside an expression -- Discarded after typecheck/rename; not passed on to desugarer = TcLclEnv { - tcl_loc :: SrcSpan, -- Source span - tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_errs :: TcRef Messages, -- Place to accumulate errors - - tcl_th_ctxt :: ThStage, -- Template Haskell context - tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context + tcl_loc :: SrcSpan, -- Source span + tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top + tcl_untch :: Untouchables, -- Birthplace for new unification variables + tcl_th_ctxt :: ThStage, -- Template Haskell context + tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context tcl_rdr :: LocalRdrEnv, -- Local name envt -- Maintained during renaming, of course, but also during @@ -429,8 +425,11 @@ data TcLclEnv -- Changes as we move inside an expression -- We still need the unsullied global name env so that -- we can look up record field names - tcl_env :: TcTypeEnv, -- The local type environment: Ids and - -- TyVars defined in this module + tcl_env :: TcTypeEnv, -- The local type environment: + -- Ids and TyVars defined in this module + + tcl_bndrs :: [TcIdBinder], -- Stack of locally-bound Ids, innermost on top + -- Used only for error reporting tcl_tidy :: TidyEnv, -- Used for tidying types; contains all -- in-scope type variables (but not term variables) @@ -441,18 +440,12 @@ data TcLclEnv -- Changes as we move inside an expression -- in tcl_lenv. -- Why mutable? see notes with tcGetGlobalTyVars - tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - - -- TcMetaTyVars have - tcl_meta :: TcRef Unique, -- The next free unique for TcMetaTyVars - -- Guaranteed to be allocated linearly - tcl_untch :: Unique -- Any TcMetaTyVar with - -- unique >= tcl_untch is touchable - -- unique < tcl_untch is untouchable + tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints + tcl_errs :: TcRef Messages -- Place to accumulate errors } type TcTypeEnv = NameEnv TcTyThing - +data TcIdBinder = TcIdBndr TcId TopLevelFlag {- Note [Given Insts] ~~~~~~~~~~~~~~~~~~ @@ -523,7 +516,8 @@ thLevel (Brack s _ _) = thLevel s + 1 -- Arrow-notation context --------------------------- -{- +{- Note [Escaping the arrow scope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In arrow notation, a variable bound by a proc (or enclosed let/kappa) is not in scope to the left of an arrow tail (-<) or the head of (|..|). For example @@ -536,10 +530,15 @@ a bit complicated: let x = 3 in proc y -> (proc z -> e1) -< e2 -Here, x and z are in scope in e1, but y is not. We implement this by +Here, x and z are in scope in e1, but y is not. + +We implement this by recording the environment when passing a proc (using newArrowScope), and returning to that (using escapeArrowScope) on the left of -< and the head of (|..|). + +All this can be dealt with by the *renamer*; by the time we get to +the *type checker* we have sorted out the scopes -} data ArrowCtxt @@ -851,9 +850,6 @@ type Xi = Type -- In many comments, "xi" ranges over Xi type Cts = Bag Ct -type SubGoalDepth = Int -- An ever increasing number used to restrict - -- simplifier iterations. Bounded by -fcontext-stack. - data Ct -- Atomic canonical constraints = CDictCan { -- e.g. Num xi @@ -861,17 +857,17 @@ data Ct cc_class :: Class, cc_tyargs :: [Xi], - cc_depth :: SubGoalDepth -- Simplification depth of this constraint - -- See Note [WorkList] + cc_loc :: CtLoc } | CIrredEvCan { -- These stand for yet-unknown predicates cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_ty :: Xi, -- cc_ty is flat hence it may only be of the form (tv xi1 xi2 ... xin) - -- Since, if it were a type constructor application, that'd make the - -- whole constraint a CDictCan, or CTyEqCan. And it can't be - -- a type family application either because it's a Xi type. - cc_depth :: SubGoalDepth -- See Note [WorkList] + -- In CIrredEvCan, the ctev_pred of the evidence is flat + -- and hence it may only be of the form (tv xi1 xi2 ... xin) + -- Since, if it were a type constructor application, that'd make the + -- whole constraint a CDictCan, or CTyEqCan. And it can't be + -- a type family application either because it's a Xi type. + cc_loc :: CtLoc } | CTyEqCan { -- tv ~ xi (recall xi means function free) @@ -883,26 +879,30 @@ data Ct cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_tyvar :: TcTyVar, cc_rhs :: Xi, - - cc_depth :: SubGoalDepth -- See Note [WorkList] + cc_loc :: CtLoc } | CFunEqCan { -- F xis ~ xi -- Invariant: * isSynFamilyTyCon cc_fun -- * typeKind (F xis) `compatKind` typeKind xi - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + 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_depth :: SubGoalDepth -- See Note [WorkList] + cc_loc :: CtLoc } | CNonCanonical { -- See Note [NonCanonical Semantics] - cc_ev :: CtEvidence, - cc_depth :: SubGoalDepth + cc_ev :: CtEvidence, + cc_loc :: CtLoc + } + + | CHoleCan { + cc_ev :: CtEvidence, + cc_loc :: CtLoc } \end{code} @@ -915,8 +915,11 @@ This holds by construction; look at the unique place where CDictCan is built (in TcCanonical) \begin{code} -mkNonCanonical :: CtEvidence -> Ct -mkNonCanonical flav = CNonCanonical { cc_ev = flav, cc_depth = 0} +mkNonCanonical :: CtLoc -> CtEvidence -> Ct +mkNonCanonical loc ev = CNonCanonical { cc_ev = ev, cc_loc = loc } + +mkNonCanonicalCt :: Ct -> Ct +mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct, cc_loc = cc_loc ct } ctEvidence :: Ct -> CtEvidence ctEvidence = cc_ev @@ -925,11 +928,12 @@ ctPred :: Ct -> PredType -- See Note [Ct/evidence invariant] ctPred ct = ctEvPred (cc_ev ct) -keepWanted :: Cts -> Cts -keepWanted = filterBag isWantedCt - -- DV: there used to be a note here that read: - -- ``Important: use fold*r*Bag to preserve the order of the evidence variables'' - -- DV: Is this still relevant? +dropDerivedWC :: WantedConstraints -> WantedConstraints +dropDerivedWC wc@(WC { wc_flat = flats }) + = wc { wc_flat = filterBag isWantedCt flats } + -- Don't filter the insolubles, because derived + -- insolubles should stay so that we report them. + -- The implications are (recursively) already filtered \end{code} @@ -941,11 +945,6 @@ keepWanted = filterBag isWantedCt %************************************************************************ \begin{code} -ctWantedLoc :: Ct -> WantedLoc --- Only works for Wanted/Derived -ctWantedLoc ct = ASSERT2( not (isGiven (cc_ev ct)), ppr ct ) - getWantedLoc (cc_ev ct) - isWantedCt :: Ct -> Bool isWantedCt = isWanted . cc_ev @@ -979,18 +978,23 @@ isCFunEqCan _ = False isCNonCanonical :: Ct -> Bool isCNonCanonical (CNonCanonical {}) = True isCNonCanonical _ = False + +isHoleCt:: Ct -> Bool +isHoleCt (CHoleCan {}) = True +isHoleCt _ = False + \end{code} \begin{code} instance Outputable Ct where - ppr ct = ppr (cc_ev ct) <+> - braces (ppr (cc_depth ct)) <+> parens (text ct_sort) + ppr ct = ppr (cc_ev ct) <+> parens (text ct_sort) where ct_sort = case ct of CTyEqCan {} -> "CTyEqCan" CFunEqCan {} -> "CFunEqCan" CNonCanonical {} -> "CNonCanonical" CDictCan {} -> "CDictCan" CIrredEvCan {} -> "CIrredEvCan" + CHoleCan {} -> "CHoleCan" \end{code} \begin{code} @@ -1057,6 +1061,9 @@ andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 }) , wc_impl = i1 `unionBags` i2 , wc_insol = n1 `unionBags` n2 } +unionsWC :: [WantedConstraints] -> WantedConstraints +unionsWC = foldr andWC emptyWC + addFlats :: WantedConstraints -> Bag Ct -> WantedConstraints addFlats wc cts = wc { wc_flat = wc_flat wc `unionBags` cts } @@ -1064,6 +1071,10 @@ addFlats wc cts addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } +addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints +addInsols wc cts + = wc { wc_insol = wc_insol wc `unionBags` cts } + instance Outputable WantedConstraints where ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n}) = ptext (sLit "WC") <+> braces (vcat @@ -1079,38 +1090,6 @@ pprBag pp b = foldrBag (($$) . pp) empty b \end{code} -\begin{code} -data Untouchables = NoUntouchables - | TouchableRange - Unique -- Low end - Unique -- High end - -- A TcMetaTyvar is *touchable* iff its unique u satisfies - -- u >= low - -- u < high - -instance Outputable Untouchables where - ppr NoUntouchables = ptext (sLit "No untouchables") - ppr (TouchableRange low high) = ptext (sLit "Touchable range:") <+> - ppr low <+> char '-' <+> ppr high - -isNoUntouchables :: Untouchables -> Bool -isNoUntouchables NoUntouchables = True -isNoUntouchables (TouchableRange {}) = False - -inTouchableRange :: Untouchables -> TcTyVar -> Bool -inTouchableRange NoUntouchables _ = True -inTouchableRange (TouchableRange low high) tv - = uniq >= low && uniq < high - where - uniq = varUnique tv - --- EvVar defined in module Var.lhs: --- Evidence variables include all *quantifiable* constraints --- dictionaries --- implicit parameters --- coercion variables -\end{code} - %************************************************************************ %* * Implication constraints @@ -1122,20 +1101,20 @@ data Implication = Implic { ic_untch :: Untouchables, -- Untouchables: unification variables -- free in the environment - ic_env :: TcTypeEnv, -- The type environment - -- Used only when generating error messages - -- Generally, ic_untch is a superset of tvsof(ic_env) - -- However, we don't zonk ic_env when zonking the Implication - -- Instead we do that when generating a skolem-escape error message ic_skols :: [TcTyVar], -- Introduced skolems - -- See Note [Skolems in an implication] + ic_info :: SkolemInfo, -- See Note [Skolems in an implication] + -- See Note [Shadowing in a constraint] + + ic_fsks :: [TcTyVar], -- Extra flatten-skolems introduced by the flattening + -- done by canonicalisation. ic_given :: [EvVar], -- Given evidence variables -- (order does not matter) - ic_loc :: GivenLoc, -- Binding location of the implication, - -- which is also the location of all the - -- given evidence variables + + ic_env :: TcLclEnv, -- Gives the source location and error context + -- for the implicatdion, and hence for all the + -- given evidence variables ic_wanted :: WantedConstraints, -- The wanted ic_insol :: Bool, -- True iff insolubleWC ic_wanted is true @@ -1145,19 +1124,32 @@ data Implication } instance Outputable Implication where - ppr (Implic { ic_untch = untch, ic_skols = skols, ic_given = given + ppr (Implic { ic_untch = untch, ic_skols = skols, ic_fsks = fsks + , ic_given = given , ic_wanted = wanted - , ic_binds = binds, ic_loc = loc }) + , ic_binds = binds, ic_info = info }) = ptext (sLit "Implic") <+> braces - (sep [ ptext (sLit "Untouchables = ") <+> ppr untch - , ptext (sLit "Skolems = ") <+> ppr skols - , ptext (sLit "Given = ") <+> pprEvVars given - , ptext (sLit "Wanted = ") <+> ppr wanted - , ptext (sLit "Binds = ") <+> ppr binds - , pprSkolInfo (ctLocOrigin loc) - , ppr (ctLocSpan loc) ]) + (sep [ ptext (sLit "Untouchables =") <+> ppr untch + , ptext (sLit "Skolems =") <+> ppr skols + , ptext (sLit "Flatten-skolems =") <+> ppr fsks + , ptext (sLit "Given =") <+> pprEvVars given + , ptext (sLit "Wanted =") <+> ppr wanted + , ptext (sLit "Binds =") <+> ppr binds + , pprSkolInfo info ]) \end{code} +Note [Shadowing in a constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We assume NO SHADOWING in a constraint. Specifically + * The unification variables are all implicitly quantified at top + level, and are all unique + * The skolem varibles bound in ic_skols are all freah when the + implication is created. +So we can safely substitute. For example, if we have + forall a. a~Int => ...(forall b. ...a...)... +we can push the (a~Int) constraint inwards in the "givens" without +worrying that 'b' might clash. + Note [Skolems in an implication] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The skolems in an implication are not there to perform a skolem escape @@ -1224,7 +1216,7 @@ pprWantedsWithLocs wcs %************************************************************************ %* * - CtLoc + CtEvidence %* * %************************************************************************ @@ -1236,70 +1228,69 @@ may be un-zonked. \begin{code} data CtEvidence - = Given { ctev_gloc :: GivenLoc - , ctev_pred :: TcPredType - , ctev_evtm :: EvTerm } -- See Note [Evidence field of CtEvidence] + = CtGiven { ctev_pred :: TcPredType + , ctev_evtm :: EvTerm } -- See Note [Evidence field of CtEvidence] -- Truly given, not depending on subgoals -- NB: Spontaneous unifications belong here - | Wanted { ctev_wloc :: WantedLoc - , ctev_pred :: TcPredType - , ctev_evar :: EvVar } -- See Note [Evidence field of CtEvidence] + | CtWanted { ctev_pred :: TcPredType + , ctev_evar :: EvVar } -- See Note [Evidence field of CtEvidence] -- Wanted goal - | Derived { ctev_wloc :: WantedLoc - , ctev_pred :: TcPredType } + | CtDerived { ctev_pred :: TcPredType } -- A goal that we don't really have to solve and can't immediately -- rewrite anything other than a derived (there's no evidence!) -- but if we do manage to solve it may help in solving other goals. +data CtFlavour = Given | Wanted | Derived + +ctFlavour :: Ct -> CtFlavour +ctFlavour ct = ctEvFlavour (cc_ev ct) + +ctEvFlavour :: CtEvidence -> CtFlavour +ctEvFlavour (CtGiven {}) = Given +ctEvFlavour (CtWanted {}) = Wanted +ctEvFlavour (CtDerived {}) = Derived + ctEvPred :: CtEvidence -> TcPredType -- The predicate of a flavor ctEvPred = ctev_pred ctEvTerm :: CtEvidence -> EvTerm -ctEvTerm (Given { ctev_evtm = tm }) = tm -ctEvTerm (Wanted { ctev_evar = ev }) = EvId ev -ctEvTerm ctev@(Derived {}) = pprPanic "ctEvTerm: derived constraint cannot have id" +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) ctEvId :: CtEvidence -> TcId -ctEvId (Wanted { ctev_evar = ev }) = ev +ctEvId (CtWanted { ctev_evar = ev }) = ev ctEvId ctev = pprPanic "ctEvId:" (ppr ctev) +instance Outputable CtFlavour where + ppr Given = ptext (sLit "[G]") + ppr Wanted = ptext (sLit "[W]") + ppr Derived = ptext (sLit "[D]") + instance Outputable CtEvidence where ppr fl = case fl of - Given {} -> ptext (sLit "[G]") <+> ppr (ctev_evtm fl) <+> ppr_pty - Wanted {} -> ptext (sLit "[W]") <+> ppr (ctev_evar fl) <+> ppr_pty - Derived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty + CtGiven {} -> ptext (sLit "[G]") <+> ppr (ctev_evtm fl) <+> ppr_pty + CtWanted {} -> ptext (sLit "[W]") <+> ppr (ctev_evar fl) <+> ppr_pty + CtDerived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty where ppr_pty = dcolon <+> ppr (ctEvPred fl) -getWantedLoc :: CtEvidence -> WantedLoc --- Precondition: Wanted or Derived -getWantedLoc fl = ctev_wloc fl - -getGivenLoc :: CtEvidence -> GivenLoc --- Precondition: Given -getGivenLoc fl = ctev_gloc fl - -pprFlavorArising :: CtEvidence -> SDoc -pprFlavorArising (Given { ctev_gloc = gl }) = pprArisingAt gl -pprFlavorArising ctev = pprArisingAt (ctev_wloc ctev) - - isWanted :: CtEvidence -> Bool -isWanted (Wanted {}) = True +isWanted (CtWanted {}) = True isWanted _ = False isGiven :: CtEvidence -> Bool -isGiven (Given {}) = True +isGiven (CtGiven {}) = True isGiven _ = False isDerived :: CtEvidence -> Bool -isDerived (Derived {}) = True -isDerived _ = False +isDerived (CtDerived {}) = True +isDerived _ = False -canSolve :: CtEvidence -> CtEvidence -> Bool +canSolve :: CtFlavour -> CtFlavour -> Bool -- canSolve ctid1 ctid2 -- The constraint ctid1 can be used to solve ctid2 -- "to solve" means a reaction where the active parts of the two constraints match. @@ -1310,19 +1301,16 @@ canSolve :: CtEvidence -> CtEvidence -> Bool -- -- NB: either (a `canSolve` b) or (b `canSolve` a) must hold ----------------------------------------- -canSolve (Given {}) _ = True -canSolve (Wanted {}) (Derived {}) = True -canSolve (Wanted {}) (Wanted {}) = True -canSolve (Derived {}) (Derived {}) = True -- Derived can't solve wanted/given +canSolve Given _ = True +canSolve Wanted Derived = True +canSolve Wanted Wanted = True +canSolve Derived Derived = True -- Derived can't solve wanted/given canSolve _ _ = False -- No evidence for a derived, anyway -canRewrite :: CtEvidence -> CtEvidence -> Bool +canRewrite :: CtFlavour -> CtFlavour -> Bool -- canRewrite ct1 ct2 -- The equality constraint ct1 can be used to rewrite inside ct2 canRewrite = canSolve - -mkGivenLoc :: WantedLoc -> SkolemInfo -> GivenLoc -mkGivenLoc wl sk = setCtLocOrigin wl sk \end{code} %************************************************************************ @@ -1337,26 +1325,49 @@ dictionaries don't appear in the original source code. type will evolve... \begin{code} -data CtLoc orig = CtLoc orig SrcSpan [ErrCtxt] +data CtLoc = CtLoc { ctl_origin :: CtOrigin + , ctl_env :: TcLclEnv + , ctl_depth :: SubGoalDepth } + -- The TcLclEnv includes particularly + -- source location: tcl_loc :: SrcSpan + -- context: tcl_ctxt :: [ErrCtxt] + -- binder stack: tcl_bndrs :: [TcIdBinders] + +type SubGoalDepth = Int -- An ever increasing number used to restrict + -- simplifier iterations. Bounded by -fcontext-stack. + -- See Note [WorkList] + +mkGivenLoc :: SkolemInfo -> TcLclEnv -> CtLoc +mkGivenLoc skol_info env = CtLoc { ctl_origin = GivenOrigin skol_info + , ctl_env = env + , ctl_depth = 0 } + +ctLocEnv :: CtLoc -> TcLclEnv +ctLocEnv = ctl_env -type WantedLoc = CtLoc CtOrigin -- Instantiation for wanted constraints -type GivenLoc = CtLoc SkolemInfo -- Instantiation for given constraints +ctLocDepth :: CtLoc -> SubGoalDepth +ctLocDepth = ctl_depth -ctLocSpan :: CtLoc o -> SrcSpan -ctLocSpan (CtLoc _ s _) = s +ctLocOrigin :: CtLoc -> CtOrigin +ctLocOrigin = ctl_origin -ctLocOrigin :: CtLoc o -> o -ctLocOrigin (CtLoc o _ _) = o +ctLocSpan :: CtLoc -> SrcSpan +ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl -setCtLocOrigin :: CtLoc o -> o' -> CtLoc o' -setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c +bumpCtLocDepth :: CtLoc -> CtLoc +bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = d+1 } -pushErrCtxt :: orig -> ErrCtxt -> CtLoc orig -> CtLoc orig -pushErrCtxt o err (CtLoc _ s errs) = CtLoc o s (err:errs) +setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc +setCtLocOrigin ctl orig = ctl { ctl_origin = orig } -pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc orig -> CtLoc orig +pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc +pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) + = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } + +pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc -- Just add information w/o updating the origin! -pushErrCtxtSameOrigin err (CtLoc o s errs) = CtLoc o s (err:errs) +pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) + = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } pprArising :: CtOrigin -> SDoc -- Used for the main, top-level error message @@ -1365,9 +1376,10 @@ pprArising (TypeEqOrigin {}) = empty pprArising FunDepOrigin = empty pprArising orig = text "arising from" <+> ppr orig -pprArisingAt :: Outputable o => CtLoc o -> SDoc -pprArisingAt (CtLoc o s _) = sep [ text "arising from" <+> ppr o - , text "at" <+> ppr s] +pprArisingAt :: CtLoc -> SDoc +pprArisingAt (CtLoc { ctl_origin = o, ctl_env = lcl}) + = sep [ text "arising from" <+> ppr o + , text "at" <+> ppr (tcl_loc lcl)] \end{code} %************************************************************************ @@ -1459,14 +1471,20 @@ pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "Unk %************************************************************************ \begin{code} --- CtOrigin gives the origin of *wanted* constraints data CtOrigin - = OccurrenceOf Name -- Occurrence of an overloaded identifier + = GivenOrigin SkolemInfo + + -- All the others are for *wanted* constraints + | OccurrenceOf Name -- Occurrence of an overloaded identifier | AppOrigin -- An application of some kind | SpecPragOrigin Name -- Specialisation pragma for identifier - | TypeEqOrigin EqOrigin + | TypeEqOrigin { uo_actual :: TcType + , uo_expected :: TcType } + | KindEqOrigin + TcType TcType -- A kind equality arising from unifying these two types + CtOrigin -- originally arising from this | IPOccOrigin HsIPName -- Occurrence of an implicit parameter @@ -1494,16 +1512,10 @@ data CtOrigin | ProcOrigin -- Arising from a proc expression | AnnOrigin -- An annotation | FunDepOrigin - -data EqOrigin - = UnifyOrigin - { uo_actual :: TcType - , uo_expected :: TcType } - -instance Outputable CtOrigin where - ppr orig = pprO orig + | HoleOrigin pprO :: CtOrigin -> SDoc +pprO (GivenOrigin sk) = ppr sk pprO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] pprO AppOrigin = ptext (sLit "an application") pprO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)] @@ -1528,11 +1540,13 @@ pprO DefaultOrigin = ptext (sLit "a 'default' declaration") pprO DoOrigin = ptext (sLit "a do statement") pprO MCompOrigin = ptext (sLit "a statement in a monad comprehension") pprO ProcOrigin = ptext (sLit "a proc expression") -pprO (TypeEqOrigin eq) = ptext (sLit "an equality") <+> ppr eq +pprO (TypeEqOrigin t1 t2) = ptext (sLit "a type equality") <+> sep [ppr t1, char '~', ppr t2] +pprO (KindEqOrigin t1 t2 _) = ptext (sLit "a kind equality arising from") <+> sep [ppr t1, char '~', ppr t2] pprO AnnOrigin = ptext (sLit "an annotation") pprO FunDepOrigin = ptext (sLit "a functional dependency") +pprO HoleOrigin = ptext (sLit "a use of the hole") <+> quotes (ptext $ sLit "_") -instance Outputable EqOrigin where - ppr (UnifyOrigin t1 t2) = ppr t1 <+> char '~' <+> ppr t2 +instance Outputable CtOrigin where + ppr = pprO \end{code} diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index f4f8c96964..1a569d02c7 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -26,7 +26,6 @@ import TcEnv import TcEvidence( TcEvBinds(..) ) import Type import Id -import NameEnv( emptyNameEnv ) import Name import Var import VarSet @@ -139,10 +138,10 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- Note [Typechecking rules] ; vars <- tcRuleBndrs hs_bndrs - ; let (id_bndrs, tv_bndrs) = partition (isId . snd) vars + ; let (id_bndrs, tv_bndrs) = partition isId vars ; (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) - <- tcExtendTyVarEnv2 tv_bndrs $ - tcExtendIdEnv2 id_bndrs $ + <- tcExtendTyVarEnv tv_bndrs $ + tcExtendIdEnv id_bndrs $ do { ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) ; (rhs', rhs_wanted) <- captureConstraints (tcMonoExpr rhs rule_ty) ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) } @@ -161,7 +160,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- the LHS, lest they otherwise get defaulted to Any; but we do that -- during zonking (see TcHsSyn.zonkRule) - ; let tpl_ids = lhs_evs ++ map snd id_bndrs + ; let tpl_ids = lhs_evs ++ id_bndrs forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids) ; zonked_forall_tvs <- zonkTyVarsAndFV forall_tvs ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked @@ -178,54 +177,61 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) ]) -- Simplify the RHS constraints - ; loc <- getCtLoc (RuleSkol name) + ; lcl_env <- getLclEnv ; rhs_binds_var <- newTcEvBinds - ; emitImplication $ Implic { ic_untch = NoUntouchables - , ic_env = emptyNameEnv + ; emitImplication $ Implic { ic_untch = noUntouchables , ic_skols = qtkvs + , ic_fsks = [] , ic_given = lhs_evs , ic_wanted = rhs_wanted , ic_insol = insolubleWC rhs_wanted , ic_binds = rhs_binds_var - , ic_loc = loc } + , ic_info = RuleSkol name + , ic_env = lcl_env } -- For the LHS constraints we must solve the remaining constraints -- (a) so that we report insoluble ones -- (b) so that we bind any soluble ones ; lhs_binds_var <- newTcEvBinds - ; emitImplication $ Implic { ic_untch = NoUntouchables - , ic_env = emptyNameEnv + ; emitImplication $ Implic { ic_untch = noUntouchables , ic_skols = qtkvs + , ic_fsks = [] , ic_given = lhs_evs , ic_wanted = other_lhs_wanted , ic_insol = insolubleWC other_lhs_wanted , ic_binds = lhs_binds_var - , ic_loc = loc } + , ic_info = RuleSkol name + , ic_env = lcl_env } ; return (HsRule name act (map (RuleBndr . noLoc) (qtkvs ++ tpl_ids)) (mkHsDictLet (TcEvBinds lhs_binds_var) lhs') fv_lhs (mkHsDictLet (TcEvBinds rhs_binds_var) rhs') fv_rhs) } -tcRuleBndrs :: [RuleBndr Name] -> TcM [(Name, Var)] +tcRuleBndrs :: [RuleBndr Name] -> TcM [Var] tcRuleBndrs [] = return [] tcRuleBndrs (RuleBndr (L _ name) : rule_bndrs) = do { ty <- newFlexiTyVarTy openTypeKind ; vars <- tcRuleBndrs rule_bndrs - ; return ((name, mkLocalId name ty) : vars) } + ; return (mkLocalId name ty : vars) } tcRuleBndrs (RuleBndrSig (L _ name) rn_ty : rule_bndrs) -- e.g x :: a->a -- The tyvar 'a' is brought into scope first, just as if you'd written -- a::*, x :: a->a = do { let ctxt = RuleSigCtxt name - ; (id_ty, skol_tvs) <- tcHsPatSigType ctxt rn_ty - ; let id = mkLocalId name id_ty + ; (id_ty, tv_prs) <- tcHsPatSigType ctxt rn_ty + ; let id = mkLocalId name id_ty + tvs = map snd tv_prs + -- tcHsPatSigType returns (Name,TyVar) pairs + -- for for RuleSigCtxt their Names are not + -- cloned, so we get (n, tv-with-name-n) pairs + -- See Note [Pattern signature binders] in TcHsType -- The type variables scope over subsequent bindings; yuk - ; vars <- tcExtendTyVarEnv2 skol_tvs $ + ; vars <- tcExtendTyVarEnv tvs $ tcRuleBndrs rule_bndrs - ; return (skol_tvs ++ (name, id) : vars) } + ; return (tvs ++ id : vars) } ruleCtxt :: FastString -> SDoc ruleCtxt name = ptext (sLit "When checking the transformation rule") <+> diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index f6f1c7878b..63c475d24a 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1,5 +1,5 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# OPTIONS -fno-warn-tabs -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See @@ -13,32 +13,31 @@ module TcSMonad ( WorkList(..), isEmptyWorkList, emptyWorkList, workListFromEq, workListFromNonEq, workListFromCt, - extendWorkListEq, extendWorkListNonEq, extendWorkListCt, - appendWorkListCt, appendWorkListEqs, unionWorkList, selectWorkItem, + extendWorkListEq, extendWorkListFunEq, + extendWorkListNonEq, extendWorkListCt, + extendWorkListCts, extendWorkListEqs, appendWorkList, selectWorkItem, + withWorkList, workListSize, - getTcSWorkList, updWorkListTcS, updWorkListTcS_return, - getTcSWorkListTvs, + updWorkListTcS, updWorkListTcS_return, - getTcSImplics, updTcSImplics, emitTcSImplication, + updTcSImplics, - Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDicts, - emitFrozenError, + Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, + emitInsoluble, isWanted, isDerived, - isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising, - - isFlexiTcsTv, instFlexiTcSHelperTcS, + isGivenCt, isWantedCt, isDerivedCt, canRewrite, canSolve, - mkGivenLoc, ctWantedLoc, + mkGivenLoc, TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality - traceFireTcS, bumpStepCountTcS, doWithInert, - tryTcS, nestImplicTcS, recoverTcS, + traceFireTcS, bumpStepCountTcS, + tryTcS, nestTcS, nestImplicTcS, recoverTcS, wrapErrTcS, wrapWarnTcS, -- Getting and setting the flattening cache - getFlatCache, updFlatCache, addToSolved, addSolvedFunEq, + addSolvedDict, addSolvedFunEq, getFlattenSkols, deferTcSForAllEq, @@ -46,11 +45,10 @@ module TcSMonad ( XEvTerm(..), MaybeNew (..), isFresh, freshGoals, getEvTerms, - xCtFlavor, -- Transform a CtEvidence during a step - rewriteCtFlavor, -- Specialized version of xCtFlavor for coercions - newWantedEvVar, instDFunConstraints, + xCtFlavor, -- Transform a CtEvidence during a step + rewriteCtFlavor, -- Specialized version of xCtFlavor for coercions + newWantedEvVar, newWantedEvVarNC, instDFunConstraints, newDerived, - xCtFlavor_cache, rewriteCtFlavor_cache, -- Creation of evidence variables setWantedTyBind, @@ -60,35 +58,37 @@ module TcSMonad ( getTcEvBindsMap, getTcSTyBinds, getTcSTyBindsMap, - newFlattenSkolemTy, -- Flatten skolems + lookupFlatEqn, newFlattenSkolem, -- Flatten skolems + + -- Deque + Deque(..), insertDeque, emptyDeque, -- Inerts InertSet(..), InertCans(..), - getInertEqs, getCtCoercion, + getInertEqs, emptyInert, getTcSInerts, lookupInInerts, - getInertUnsolved, getInertInsols, splitInertsForImplications, + getInertUnsolved, checkAllSolved, + prepareInertsForImplications, modifyInertTcS, - updInertSetTcS, partitionCCanMap, partitionEqMap, + insertInertItemTcS, partitionCCanMap, partitionEqMap, getRelevantCts, extractRelevantInerts, CCanMap(..), CtTypeMap, CtFamHeadMap, CtPredMap, PredMap, FamHeadMap, - partCtFamHeadMap, lookupFamHead, + partCtFamHeadMap, lookupFamHead, lookupSolvedDict, filterSolved, instDFunType, -- Instantiation - newFlexiTcSTy, instFlexiTcS, + newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS, + cloneMetaTyVar, compatKind, mkKindErrorCtxtTcS, - TcsUntouchables, - isTouchableMetaTyVar, - isTouchableMetaTyVar_InRange, + Untouchables, isTouchableMetaTyVarTcS, isFilledMetaTyVar_maybe, getDefaultInfo, getDynFlags, matchClass, matchFam, MatchInstResult (..), checkWellStagedDFun, - warnTcS, pprEq -- Smaller utils, re-exported from TcM -- TODO (DV): these are only really used in the -- instance matcher in TcSimplify. I am wondering @@ -125,7 +125,6 @@ import VarEnv import Outputable import Bag import MonadUtils -import VarSet import FastString import Util @@ -134,17 +133,18 @@ import TcRnTypes import Unique import UniqFM -#ifdef DEBUG -import Digraph -#endif -import Maybes ( orElse, catMaybes ) - +import Maybes ( orElse, catMaybes, firstJust ) +import StaticFlags( opt_NoFlatCache ) import Control.Monad( unless, when, zipWithM ) -import StaticFlags( opt_PprStyle_Debug ) import Data.IORef import TrieMap +#ifdef DEBUG +import StaticFlags( opt_PprStyle_Debug ) +import VarSet +import Digraph +#endif \end{code} @@ -169,8 +169,8 @@ mkKindErrorCtxtTcS ty1 ki1 ty2 ki2 %* * %************************************************************************ -Note [WorkList] -~~~~~~~~~~~~~~~ +Note [WorkList priorities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ A WorkList contains canonical and non-canonical items (of all flavors). Notice that each Ct now has a simplification depth. We may consider using this depth for prioritization as well in the future. @@ -181,6 +181,7 @@ so that it's easier to deal with them first, but the separation is not strictly necessary. Notice that non-canonical constraints are also parts of the worklist. + Note [NonCanonical Semantics] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that canonical constraints involve a CNonCanonical constructor. In the worklist @@ -196,29 +197,68 @@ be rewritten by equalities (for instance if a non canonical exists in the inert, 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 --- See Note [WorkList] +instance Outputable a => Outputable (Deque a) where + ppr (DQ as bs) = ppr (as ++ reverse bs) -- Show first one to come out at the start + +emptyDeque :: Deque a +emptyDeque = DQ [] [] + +isEmptyDeque :: Deque a -> Bool +isEmptyDeque (DQ as bs) = null as && null bs + +dequeSize :: Deque a -> Int +dequeSize (DQ as bs) = length as + length bs + +insertDeque :: a -> Deque a -> Deque a +insertDeque b (DQ as bs) = DQ as (b:bs) + +appendDeque :: Deque a -> Deque a -> Deque a +appendDeque (DQ as1 bs1) (DQ as2 bs2) = DQ (as1 ++ reverse bs1 ++ as2) bs2 + +extractDeque :: Deque a -> Maybe (Deque a, a) +extractDeque (DQ [] []) = Nothing +extractDeque (DQ (a:as) bs) = Just (DQ as bs, a) +extractDeque (DQ [] bs) = case reverse bs of + (a:as) -> Just (DQ as [], a) + [] -> panic "extractDeque" + +-- See Note [WorkList priorities] data WorkList = WorkList { wl_eqs :: [Ct] - , wl_funeqs :: [Ct] + , wl_funeqs :: Deque Ct , wl_rest :: [Ct] } -unionWorkList :: WorkList -> WorkList -> WorkList -unionWorkList new_wl orig_wl = - WorkList { wl_eqs = wl_eqs new_wl ++ wl_eqs orig_wl - , wl_funeqs = wl_funeqs new_wl ++ wl_funeqs orig_wl - , wl_rest = wl_rest new_wl ++ wl_rest orig_wl } +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 } +workListSize :: WorkList -> Int +workListSize (WorkList { 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 - = wl { wl_funeqs = ct : wl_funeqs wl } + = extendWorkListFunEq ct wl | otherwise = 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 @@ -230,20 +270,16 @@ extendWorkListCt ct wl | isEqPred (ctPred ct) = extendWorkListEq ct wl | otherwise = extendWorkListNonEq ct wl -appendWorkListCt :: [Ct] -> WorkList -> WorkList +extendWorkListCts :: [Ct] -> WorkList -> WorkList -- Agnostic -appendWorkListCt cts wl = foldr extendWorkListCt wl cts - -appendWorkListEqs :: [Ct] -> WorkList -> WorkList --- Append a list of equalities -appendWorkListEqs cts wl = foldr extendWorkListEq wl cts +extendWorkListCts cts wl = foldr extendWorkListCt wl cts isEmptyWorkList :: WorkList -> Bool isEmptyWorkList wl - = null (wl_eqs wl) && null (wl_rest wl) && null (wl_funeqs wl) + = null (wl_eqs wl) && null (wl_rest wl) && isEmptyDeque (wl_funeqs wl) emptyWorkList :: WorkList -emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = [] } +emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = emptyDeque } workListFromEq :: Ct -> WorkList workListFromEq ct = extendWorkListEq ct emptyWorkList @@ -261,7 +297,8 @@ selectWorkItem :: WorkList -> (Maybe Ct, WorkList) selectWorkItem wl@(WorkList { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest }) = case (eqs,feqs,rest) of (ct:cts,_,_) -> (Just ct, wl { wl_eqs = cts }) - (_,(ct:cts),_) -> (Just ct, wl { wl_funeqs = cts }) + (_,fun_eqs,_) | Just (fun_eqs', ct) <- extractDeque fun_eqs + -> (Just ct, wl { wl_funeqs = fun_eqs' }) (_,_,(ct:cts)) -> (Just ct, wl { wl_rest = cts }) (_,_,_) -> (Nothing,wl) @@ -274,12 +311,16 @@ instance Outputable WorkList where -- Canonical constraint maps -data CCanMap a = CCanMap { cts_given :: UniqFM Cts - -- Invariant: all Given - , cts_derived :: UniqFM Cts - -- Invariant: all Derived - , cts_wanted :: UniqFM Cts } - -- Invariant: all Wanted +data CCanMap a + = CCanMap { cts_given :: UniqFM Cts -- All Given + , cts_derived :: UniqFM Cts -- All Derived + , cts_wanted :: UniqFM Cts } -- All Wanted + +keepGivenCMap :: CCanMap a -> CCanMap a +keepGivenCMap cc = emptyCCanMap { cts_given = cts_given cc } + +instance Outputable (CCanMap a) where + ppr (CCanMap given derived wanted) = ptext (sLit "CCanMap") <+> (ppr given) <+> (ppr derived) <+> (ppr wanted) cCanMapToBag :: CCanMap a -> Cts cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap) @@ -292,9 +333,9 @@ emptyCCanMap = CCanMap { cts_given = emptyUFM, cts_derived = emptyUFM, cts_wante updCCanMap:: Uniquable a => (a,Ct) -> CCanMap a -> CCanMap a updCCanMap (a,ct) cmap = case cc_ev ct of - Wanted {} -> cmap { cts_wanted = insert_into (cts_wanted cmap) } - Given {} -> cmap { cts_given = insert_into (cts_given cmap) } - Derived {} -> cmap { cts_derived = insert_into (cts_derived cmap) } + CtWanted {} -> cmap { cts_wanted = insert_into (cts_wanted cmap) } + CtGiven {} -> cmap { cts_given = insert_into (cts_given cmap) } + CtDerived {} -> cmap { cts_derived = insert_into (cts_derived cmap) } where insert_into m = addToUFM_C unionBags m a (singleCt ct) @@ -351,23 +392,10 @@ partitionEqMap pred isubst in (eqs_out, eqs_in) where extend_if_pred (ct,_) cts = if pred ct then ct : cts else cts - -extractUnsolvedCMap :: CCanMap a -> (Cts, CCanMap a) --- Gets the wanted or derived constraints and returns a residual --- CCanMap with only givens. -extractUnsolvedCMap cmap = - let wntd = foldUFM unionBags emptyCts (cts_wanted cmap) - derd = foldUFM unionBags emptyCts (cts_derived cmap) - in (wntd `unionBags` derd, - cmap { cts_wanted = emptyUFM, cts_derived = emptyUFM }) - -extractWantedCMap :: CCanMap a -> (Cts, CCanMap a) --- Gets the wanted /only/ constraints and returns a residual --- CCanMap with only givens or derived -extractWantedCMap cmap = - let wntd = foldUFM unionBags emptyCts (cts_wanted cmap) - in (wntd, cmap { cts_wanted = emptyUFM }) - +extractUnsolvedCMap :: CCanMap a -> Cts +-- Gets the wanted or derived constraints +extractUnsolvedCMap cmap = foldUFM unionBags emptyCts (cts_wanted cmap) + `unionBags` foldUFM unionBags emptyCts (cts_derived cmap) -- Maps from PredTypes to Constraints type CtTypeMap = TypeMap Ct @@ -383,12 +411,30 @@ instance Outputable a => Outputable (PredMap a) where instance Outputable a => Outputable (FamHeadMap a) where ppr (FamHeadMap m) = ppr (foldTM (:) m []) +sizePredMap :: PredMap a -> Int +sizePredMap (PredMap m) = foldTypeMap (\_ x -> x+1) 0 m + +emptyFamHeadMap :: FamHeadMap a +emptyFamHeadMap = FamHeadMap emptyTM + +sizeFamHeadMap :: FamHeadMap a -> Int +sizeFamHeadMap (FamHeadMap m) = foldTypeMap (\_ x -> x+1) 0 m + ctTypeMapCts :: TypeMap Ct -> Cts ctTypeMapCts ctmap = foldTM (\ct cts -> extendCts cts ct) ctmap emptyCts lookupFamHead :: FamHeadMap a -> TcType -> Maybe a lookupFamHead (FamHeadMap m) key = lookupTM key m +insertFamHead :: FamHeadMap a -> TcType -> a -> FamHeadMap a +insertFamHead (FamHeadMap m) key value = FamHeadMap (alterTM key (const (Just value)) m) + +delFamHead :: FamHeadMap a -> TcType -> FamHeadMap a +delFamHead (FamHeadMap m) key = FamHeadMap (alterTM key (const Nothing) m) + +anyFamHeadMap :: (Ct -> Bool) -> CtFamHeadMap -> Bool +anyFamHeadMap f ctmap = foldTM ((||) . f) (unFamHeadMap ctmap) False + partCtFamHeadMap :: (Ct -> Bool) -> CtFamHeadMap -> (Cts, CtFamHeadMap) @@ -418,30 +464,6 @@ filterSolved p (PredMap mp) = PredMap (foldTM upd mp emptyTM) %* * %************************************************************************ -\begin{code} --- All Given (fully known) or Wanted or Derived --- See Note [Detailed InertCans Invariants] for more -data InertCans - = IC { inert_eqs :: TyVarEnv Ct - -- Must all be CTyEqCans! If an entry exists of the form: - -- a |-> ct,co - -- Then ct = CTyEqCan { cc_tyvar = a, cc_rhs = xi } - -- And co : a ~ xi - , inert_eq_tvs :: InScopeSet - -- Superset of the type variables of inert_eqs - , inert_dicts :: CCanMap Class - -- Dictionaries only, index is the class - -- NB: index is /not/ the whole type because FD reactions - -- need to match the class but not necessarily the whole type. - , inert_funeqs :: CtFamHeadMap - -- Family equations, index is the whole family head type. - , inert_irreds :: Cts - -- Irreducible predicates - } - - -\end{code} - Note [Detailed InertCans Invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The InertCans represents a collection of constraints with the following properties: @@ -500,105 +522,138 @@ The reason for all this is simply to avoid re-solving goals we have solved alrea 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 + + * The work-list, of course + + * The inert_flat_cache. This is used when flattening, to get maximal + sharing. It contains lots of things that are still in the work-list. + E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the + work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work + list. Now if we flatten w2 before we get to w3, we still want to + share that (G a). + + Because it contains work-list things, DO NOT use the flat cache to solve + 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 +data InertCans + = IC { inert_eqs :: TyVarEnv Ct + -- Must all be CTyEqCans! If an entry exists of the form: + -- a |-> ct,co + -- Then ct = CTyEqCan { cc_tyvar = a, cc_rhs = xi } + -- And co : a ~ xi + , inert_dicts :: CCanMap Class + -- Dictionaries only, index is the class + -- NB: index is /not/ the whole type because FD reactions + -- need to match the class but not necessarily the whole type. + , inert_funeqs :: CtFamHeadMap + -- Family equations, index is the whole family head type. + , inert_irreds :: Cts + -- Irreducible predicates + + , inert_insols :: Cts + -- Frozen errors (as non-canonicals) + } + + -- The Inert Set data InertSet = IS { inert_cans :: InertCans -- Canonical Given, Wanted, Derived (no Solved) -- Sometimes called "the inert set" - , inert_frozen :: Cts - -- Frozen errors (as non-canonicals) - - , inert_flat_cache :: CtFamHeadMap - -- All ``flattening equations'' are kept here. - -- Always canonical CTyFunEqs (Given or Wanted only!) - -- Key is by family head. We use this field during flattening only + , inert_flat_cache :: FamHeadMap (CtEvidence, TcType) + -- See Note [Type family equations] + -- 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 + -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache + -- when allocating a new flatten-skolem. -- Not necessarily inert wrt top-level equations (or inert_cans) - - , inert_solved_funeqs :: FamHeadMap CtEvidence -- Of form co :: F xis ~ xi - -- No Deriveds - - , inert_solved :: PredMap CtEvidence -- All others - -- These two fields constitute a cache of solved (only!) constraints + + , inert_fsks :: [TcTyVar] -- Rigid flatten-skolems (arising from givens) + -- allocated in this local scope + + , inert_solved_funeqs :: FamHeadMap (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 :: PredMap CtEvidence + -- Of form ev :: C t1 .. tn + -- Always the result of using a top-level instance declaration -- See Note [Solved constraints] - -- - Constraints of form (F xis ~ xi) live in inert_solved_funeqs, - -- all the others are in inert_solved - -- - Used to avoid creating a new EvVar when we have a new goal that we - -- have solvedin the past + -- - Used to avoid creating a new EvVar when we have a new goal + -- that we have solved in the past -- - Stored not necessarily as fully rewritten -- (ToDo: rewrite lazily when we lookup) } instance Outputable InertCans where - ppr ics = vcat [ vcat (map ppr (varEnvElts (inert_eqs ics))) - , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts ics))) - , vcat (map ppr (Bag.bagToList $ + ppr ics = vcat [ ptext (sLit "Equalities:") + <+> vcat (map ppr (varEnvElts (inert_eqs ics))) + , ptext (sLit "Type-function equalities:") + <+> vcat (map ppr (Bag.bagToList $ ctTypeMapCts (unFamHeadMap $ inert_funeqs ics))) - , vcat (map ppr (Bag.bagToList $ inert_irreds ics)) + , ptext (sLit "Dictionaries:") + <+> vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts ics))) + , ptext (sLit "Irreds:") + <+> vcat (map ppr (Bag.bagToList $ inert_irreds ics)) + , text "Insolubles =" <+> -- Clearly print frozen errors + braces (vcat (map ppr (Bag.bagToList $ inert_insols ics))) ] instance Outputable InertSet where ppr is = vcat [ ppr $ inert_cans is - , text "Frozen errors =" <+> -- Clearly print frozen errors - braces (vcat (map ppr (Bag.bagToList $ inert_frozen is))) - , text "Solved and cached" <+> - int (foldTypeMap (\_ x -> x+1) 0 - (unPredMap $ inert_solved is)) <+> - text "more constraints" ] + , text "Solved dicts" <+> int (sizePredMap (inert_solved_dicts is)) + , text "Solved funeqs" <+> int (sizeFamHeadMap (inert_solved_funeqs is))] emptyInert :: InertSet emptyInert = IS { inert_cans = IC { inert_eqs = emptyVarEnv - , inert_eq_tvs = emptyInScopeSet , inert_dicts = emptyCCanMap - , inert_funeqs = FamHeadMap emptyTM - , inert_irreds = emptyCts } - , inert_frozen = emptyCts - , inert_flat_cache = FamHeadMap emptyTM - , inert_solved = PredMap emptyTM - , inert_solved_funeqs = FamHeadMap emptyTM } - -updSolvedSet :: InertSet -> CtEvidence -> InertSet -updSolvedSet is item - = let pty = ctEvPred item - upd_solved Nothing = Just item - upd_solved (Just _existing_solved) = Just item - -- .. or Just existing_solved? Is this even possible to happen? - in is { inert_solved = - PredMap $ - alterTM pty upd_solved (unPredMap $ inert_solved is) } - - -updInertSet :: InertSet -> Ct -> InertSet + , inert_funeqs = emptyFamHeadMap + , inert_irreds = emptyCts + , inert_insols = emptyCts } + , inert_fsks = [] + , inert_flat_cache = emptyFamHeadMap + , inert_solved_dicts = PredMap emptyTM + , inert_solved_funeqs = emptyFamHeadMap } + +insertInertItem :: Ct -> InertSet -> InertSet -- Add a new inert element to the inert set. -updInertSet is item - | isCNonCanonical item - -- NB: this may happen if we decide to kick some frozen error - -- out to rewrite him. Frozen errors are just NonCanonicals - = is { inert_frozen = inert_frozen is `Bag.snocBag` item } - - | otherwise - -- A canonical Given, Wanted, or Derived - = is { inert_cans = upd_inert_cans (inert_cans is) item } +insertInertItem item is + = -- A canonical Given, Wanted, or Derived + is { inert_cans = upd_inert_cans (inert_cans is) item } where upd_inert_cans :: InertCans -> Ct -> InertCans -- Precondition: item /is/ canonical upd_inert_cans ics item | isCTyEqCan item - = let upd_err a b = pprPanic "updInertSet" $ + = let upd_err a b = pprPanic "insertInertItem" $ vcat [ text "Multiple inert equalities:" , text "Old (already inert):" <+> ppr a , text "Trying to insert :" <+> ppr b ] eqs' = extendVarEnv_C upd_err (inert_eqs ics) (cc_tyvar item) item - inscope' = extendInScopeSetSet (inert_eq_tvs ics) - (tyVarsOfCt item) - - in ics { inert_eqs = eqs', inert_eq_tvs = inscope' } + + in ics { inert_eqs = eqs' } | isCIrredEvCan item -- Presently-irreducible evidence = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item } @@ -610,50 +665,46 @@ updInertSet is item = let fam_head = mkTyConApp (cc_fun item) (cc_tyargs item) upd_funeqs Nothing = Just item upd_funeqs (Just _already_there) - = panic "updInertSet: item already there!" + = panic "insertInertItem: item already there!" in ics { inert_funeqs = FamHeadMap (alterTM fam_head upd_funeqs $ (unFamHeadMap $ inert_funeqs ics)) } | otherwise = pprPanic "upd_inert set: can't happen! Inserting " $ - ppr item + ppr item -- Can't be CNonCanonical, CHoleCan, + -- because they only land in inert_insols -updInertSetTcS :: Ct -> TcS () + +insertInertItemTcS :: Ct -> TcS () -- Add a new item in the inerts of the monad -updInertSetTcS item - = do { traceTcS "updInertSetTcs {" $ +insertInertItemTcS item + = do { traceTcS "insertInertItemTcS {" $ text "Trying to insert new inert item:" <+> ppr item - ; modifyInertTcS (\is -> ((), updInertSet is item)) + ; updInertTcS (insertInertItem item) - ; traceTcS "updInertSetTcs }" $ empty } - + ; traceTcS "insertInertItemTcS }" $ empty } -addToSolved :: CtEvidence -> TcS () +addSolvedDict :: CtEvidence -> TcS () -- Add a new item in the solved set of the monad -addToSolved item +addSolvedDict item | isIPPred (ctEvPred item) -- Never cache "solved" implicit parameters (not sure why!) = return () | otherwise - = do { traceTcS "updSolvedSetTcs {" $ - text "Trying to insert new solved item:" <+> ppr item - - ; modifyInertTcS (\is -> ((), updSolvedSet is item)) - - ; traceTcS "updSolvedSetTcs }" $ empty } - -addSolvedFunEq :: CtEvidence -> TcS () -addSolvedFunEq fun_eq - = modifyInertTcS $ \inert -> ((), upd_inert inert) - where - upd_inert inert - = let slvd = unFamHeadMap (inert_solved_funeqs inert) - in inert { inert_solved_funeqs = - FamHeadMap (alterTM key upd_funeqs slvd) } - upd_funeqs Nothing = Just fun_eq - upd_funeqs (Just _ct) = Just fun_eq - -- Or _ct? depends on which caches more steps of computation - key = ctEvPred fun_eq + = do { traceTcS "updSolvedSetTcs:" $ ppr item + ; updInertTcS upd_solved_dicts } + where + upd_solved_dicts is + = is { inert_solved_dicts = PredMap $ alterTM pred upd_solved $ + unPredMap $ inert_solved_dicts is } + pred = ctEvPred item + upd_solved _ = Just item + +addSolvedFunEq :: TcType -> CtEvidence -> TcType -> TcS () +addSolvedFunEq fam_ty ev rhs_ty + = updInertTcS $ \ inert -> + inert { inert_solved_funeqs = insertFamHead (inert_solved_funeqs inert) + fam_ty (ev, rhs_ty) } modifyInertTcS :: (InertSet -> (a,InertSet)) -> TcS a -- Modify the inert set with the supplied function @@ -664,95 +715,127 @@ modifyInertTcS upd ; wrapTcS (TcM.writeTcRef is_var new_inert) ; return a } +updInertTcS :: (InertSet -> InertSet) -> TcS () +-- Modify the inert set with the supplied function +updInertTcS upd + = do { is_var <- getTcSInertsRef + ; curr_inert <- wrapTcS (TcM.readTcRef is_var) + ; let new_inert = upd curr_inert + ; wrapTcS (TcM.writeTcRef is_var new_inert) } + +prepareInertsForImplications :: InertSet -> InertSet +-- See Note [Preparing inert set for implications] +prepareInertsForImplications is + = is { inert_cans = getGivens (inert_cans is) + , inert_fsks = [] + , inert_flat_cache = emptyFamHeadMap } + where + getGivens (IC { inert_eqs = eqs + , inert_irreds = irreds + , inert_funeqs = FamHeadMap funeqs + , inert_dicts = dicts }) + = IC { inert_eqs = filterVarEnv_Directly (\_ ct -> isGivenCt ct) eqs + , inert_funeqs = FamHeadMap (mapTM given_from_wanted funeqs) + , inert_irreds = Bag.filterBag isGivenCt irreds + , inert_dicts = keepGivenCMap dicts + , inert_insols = emptyCts } + + given_from_wanted funeq -- This is where the magic processing happens + | isGiven ev = funeq -- for type-function equalities + -- See Note [Preparing inert set for implications] + | otherwise = funeq { cc_ev = given_ev } + where + ev = ctEvidence funeq + given_ev = CtGiven { ctev_evtm = EvId (ctev_evar ev) + , ctev_pred = ctev_pred ev } +\end{code} +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. -splitInertsForImplications :: InertSet -> ([Ct],InertSet) --- Converts the Wanted of the original inert to Given and removes --- all Wanted and Derived from the inerts. --- DV: Is the removal of Derived essential? -splitInertsForImplications is - = let (cts,is') = extractWanted is - in (givens_from_unsolved cts,is') - where givens_from_unsolved = foldrBag get_unsolved [] - get_unsolved cc rest_givens - | pushable_wanted cc - = let fl = ctEvidence cc - gfl = Given { ctev_gloc = setCtLocOrigin (ctev_wloc fl) UnkSkol - , ctev_evtm = EvId (ctev_evar fl) - , ctev_pred = ctev_pred fl } - this_given = cc { cc_ev = gfl } - in this_given : rest_givens - | otherwise = rest_givens - - pushable_wanted :: Ct -> Bool - pushable_wanted cc - = isEqPred (ctPred cc) -- see Note [Preparing inert set for implications] - - -- Returns Wanted constraints and a Derived/Given InertSet - extractWanted (IS { inert_cans = IC { inert_eqs = eqs - , inert_eq_tvs = eq_tvs - , inert_irreds = irreds - , inert_funeqs = funeqs - , inert_dicts = dicts - } - , inert_frozen = _frozen - , inert_solved = solved - , inert_flat_cache = flat_cache - , inert_solved_funeqs = funeq_cache - }) - - = let is_solved = IS { inert_cans = IC { inert_eqs = solved_eqs - , inert_eq_tvs = eq_tvs - , inert_dicts = solved_dicts - , inert_irreds = solved_irreds - , inert_funeqs = solved_funeqs } - , inert_frozen = emptyCts -- All out - - -- At some point, I used to flush all the solved, in - -- fear of evidence loops. But I think we are safe, - -- flushing is why T3064 had become slower - , inert_solved = solved -- PredMap emptyTM - , inert_flat_cache = flat_cache -- FamHeadMap emptyTM - , inert_solved_funeqs = funeq_cache -- FamHeadMap emptyTM - } - in (wanted, is_solved) - - where gd_eqs = filterVarEnv_Directly (\_ ct -> not (isWantedCt ct)) eqs - wanted_eqs = foldVarEnv (\ct cts -> cts `extendCts` ct) emptyCts $ - eqs `minusVarEnv` gd_eqs - - (wanted_irreds, gd_irreds) = Bag.partitionBag isWantedCt irreds - (wanted_dicts, gd_dicts) = extractWantedCMap dicts - (wanted_funeqs, gd_funeqs) = partCtFamHeadMap isWantedCt funeqs +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 + + 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 +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. - -- Is this all necessary? - solved_eqs = filterVarEnv_Directly (\_ ct -> isGivenCt ct) gd_eqs - solved_irreds = Bag.filterBag isGivenCt gd_irreds - (_,solved_dicts) = extractUnsolvedCMap gd_dicts - (_,solved_funeqs) = partCtFamHeadMap (not . isGivenCt) gd_funeqs - wanted = wanted_eqs `unionBags` wanted_irreds `unionBags` - wanted_dicts `unionBags` wanted_funeqs +\begin{code} +getInertEqs :: TcS (TyVarEnv Ct) +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 = extractUnsolvedCMap (inert_dicts icans) + (unsolved_funeqs,_) = partCtFamHeadMap is_unsolved (inert_funeqs icans) + unsolved_eqs = foldVarEnv add_if_unsolved emptyCts (inert_eqs icans) + unsolved_flats = unsolved_eqs `unionBags` unsolved_irreds `unionBags` + unsolved_dicts `unionBags` unsolved_funeqs -getInertInsols :: InertSet -> Cts --- Insolubles only -getInertInsols is = inert_frozen is + ; return (unsolved_flats, inert_insols icans) } + where + add_if_unsolved ct cts + | is_unsolved ct = cts `extendCts` ct + | otherwise = cts + + is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived -getInertUnsolved :: InertSet -> Cts --- Unsolved Wanted or Derived only -getInertUnsolved (IS { inert_cans = icans }) - = let unsolved_eqs = foldVarEnv add_if_not_given emptyCts (inert_eqs icans) - add_if_not_given ct cts - | isGivenCt ct = cts - | otherwise = cts `extendCts` ct - (unsolved_irreds,_) = Bag.partitionBag (not . isGivenCt) (inert_irreds icans) - (unsolved_dicts,_) = extractUnsolvedCMap (inert_dicts icans) - (unsolved_funeqs,_) = partCtFamHeadMap (not . isGivenCt) (inert_funeqs icans) - in unsolved_eqs `unionBags` unsolved_irreds `unionBags` - unsolved_dicts `unionBags` unsolved_funeqs +checkAllSolved :: TcS Bool +-- True if there are no unsolved wanteds +-- Ignore Derived for this purpose, unless in insolubles +checkAllSolved + = do { is <- getTcSInerts + ; let icans = inert_cans is + unsolved_irreds = Bag.anyBag isWantedCt (inert_irreds icans) + unsolved_dicts = not (isNullUFM (cts_wanted (inert_dicts icans))) + unsolved_funeqs = anyFamHeadMap isWantedCt (inert_funeqs icans) + unsolved_eqs = foldVarEnv ((||) . isWantedCt) False (inert_eqs icans) + ; return (not (unsolved_eqs || unsolved_irreds + || unsolved_dicts || unsolved_funeqs + || not (isEmptyBag (inert_insols icans)))) } extractRelevantInerts :: Ct -> TcS Cts -- Returns the constraints from the inert set that are 'relevant' to react with @@ -767,34 +850,51 @@ extractRelevantInerts wi extract_ics_relevants (CDictCan {cc_class = cl}) ics = let (cts,dict_map) = getRelevantCts cl (inert_dicts ics) in (cts, ics { inert_dicts = dict_map }) - extract_ics_relevants ct@(CFunEqCan {}) ics = - let (cts,feqs_map) = - let funeq_map = unFamHeadMap $ inert_funeqs ics - fam_head = mkTyConApp (cc_fun ct) (cc_tyargs ct) - lkp = lookupTM fam_head funeq_map - new_funeq_map = alterTM fam_head xtm funeq_map - xtm Nothing = Nothing - xtm (Just _ct) = Nothing - in case lkp of - Nothing -> (emptyCts, funeq_map) - Just ct -> (singleCt ct, new_funeq_map) - in (cts, ics { inert_funeqs = FamHeadMap feqs_map }) + + extract_ics_relevants ct@(CFunEqCan {}) ics@(IC { inert_funeqs = funeq_map }) + | Just ct <- lookupFamHead funeq_map fam_head + = (singleCt ct, ics { inert_funeqs = delFamHead funeq_map fam_head }) + | otherwise + = (emptyCts, ics) + where + fam_head = mkTyConApp (cc_fun ct) (cc_tyargs ct) + + extract_ics_relevants (CHoleCan {}) ics + = pprPanic "extractRelevantInerts" (ppr wi) + -- Holes are put straight into inert_frozen, so never get here + extract_ics_relevants (CIrredEvCan { }) ics = let cts = inert_irreds ics in (cts, ics { inert_irreds = emptyCts }) + extract_ics_relevants _ ics = (emptyCts,ics) -lookupInInerts :: InertSet -> TcPredType -> Maybe CtEvidence +lookupFlatEqn :: TcType -> TcS (Maybe (CtEvidence, TcType)) +lookupFlatEqn fam_ty + = do { IS { inert_solved_funeqs = solved_funeqs + , inert_flat_cache = flat_cache + , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts + ; return (lookupFamHead solved_funeqs fam_ty `firstJust` + lookupFamHead flat_cache fam_ty `firstJust` + lookup_in_inerts inert_funeqs) } + where + lookup_in_inerts inert_funeqs + = case lookupFamHead inert_funeqs fam_ty of + Nothing -> Nothing + Just ct -> Just (ctEvidence ct, cc_rhs ct) + +lookupInInerts :: TcPredType -> TcS (Maybe CtEvidence) -- Is this exact predicate type cached in the solved or canonicals of the InertSet -lookupInInerts (IS { inert_solved = solved, inert_cans = ics }) pty - = case lookupInSolved solved pty of - Just ctev -> return ctev - Nothing -> lookupInInertCans ics pty +lookupInInerts pty + = do { IS { inert_solved_dicts = solved, inert_cans = ics } <- getTcSInerts + ; case lookupSolvedDict solved pty of + Just ctev -> return (Just ctev) + Nothing -> return (lookupInInertCans ics pty) } -lookupInSolved :: PredMap CtEvidence -> TcPredType -> Maybe CtEvidence +lookupSolvedDict :: PredMap CtEvidence -> TcPredType -> Maybe CtEvidence -- Returns just if exactly this predicate type exists in the solved. -lookupInSolved tm pty = lookupTM pty $ unPredMap tm +lookupSolvedDict tm pty = lookupTM pty $ unPredMap tm lookupInInertCans :: InertCans -> TcPredType -> Maybe CtEvidence -- Returns Just if exactly this pred type exists in the inert canonicals @@ -818,7 +918,7 @@ lookupInInertCans ics pty IrredPred {} -> findEvidence (\ct -> ctEvPred ct `eqType` pty) (inert_irreds ics) - _other -> Nothing -- NB: No caching for IPs + _other -> Nothing -- NB: No caching for IPs or holes \end{code} @@ -851,23 +951,17 @@ data TcSEnv tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)), -- Global type bindings - tcs_untch :: TcsUntouchables, - - tcs_ic_depth :: Int, -- Implication nesting depth 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 the current worklist. + -- 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) } - -type TcsUntouchables = (Untouchables,TcTyVarSet) --- Like the TcM Untouchables, --- but records extra TcsTv variables generated during simplification --- See Note [Extra TcsTv untouchables] in TcSimplify \end{code} \begin{code} @@ -908,41 +1002,46 @@ panicTcS doc = pprPanic "TcCanonical" doc traceTcS :: String -> SDoc -> TcS () traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) +instance HasDynFlags TcS where + getDynFlags = wrapTcS getDynFlags + bumpStepCountTcS :: TcS () bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env ; n <- TcM.readTcRef ref ; TcM.writeTcRef ref (n+1) } -traceFireTcS :: SubGoalDepth -> SDoc -> TcS () +traceFireTcS :: Ct -> SDoc -> TcS () -- Dump a rule-firing trace -traceFireTcS depth doc +traceFireTcS ct doc = TcS $ \env -> TcM.ifDOptM Opt_D_dump_cs_trace $ do { n <- TcM.readTcRef (tcs_count env) - ; let msg = int n - <> text (replicate (tcs_ic_depth env) '>') - <> brackets (int depth) <+> doc + ; let msg = int n <> brackets (int (ctLocDepth (cc_loc ct))) <+> doc ; TcM.dumpTcRn msg } +runTcS :: TcS a -- What to run + -> TcM (a, Bag EvBind) +runTcS tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; res <- runTcSWithEvBinds ev_binds_var tcs + ; ev_binds <- TcM.getTcEvBinds ev_binds_var + ; return (res, ev_binds) } + runTcSWithEvBinds :: EvBindsVar -> TcS a -> TcM a runTcSWithEvBinds ev_binds_var tcs = do { ty_binds_var <- TcM.newTcRef emptyVarEnv - ; impl_var <- TcM.newTcRef emptyBag ; step_count <- TcM.newTcRef 0 - ; inert_var <- TcM.newTcRef is - ; wl_var <- TcM.newTcRef wl ; let env = TcSEnv { tcs_ev_binds = ev_binds_var , tcs_ty_binds = ty_binds_var - , tcs_untch = (untouch, emptyVarSet) -- No Tcs untouchables yet , tcs_count = step_count - , tcs_ic_depth = 0 , tcs_inerts = inert_var - , tcs_worklist = wl_var - , tcs_implics = impl_var } + , tcs_worklist = panic "runTcS: worklist" + , tcs_implics = panic "runTcS: implics" } + -- NB: Both these are initialised by withWorkList -- Run the computation ; res <- unTcS tcs env @@ -950,32 +1049,22 @@ runTcSWithEvBinds ev_binds_var tcs ; ty_binds <- TcM.readTcRef ty_binds_var ; mapM_ do_unification (varEnvElts ty_binds) - ; when debugIsOn $ - do { count <- TcM.readTcRef step_count - ; when (opt_PprStyle_Debug && count > 0) $ - TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count ) } - -- And return +#ifdef DEBUG + ; count <- TcM.readTcRef step_count + ; when (opt_PprStyle_Debug && count > 0) $ + TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count ) + ; ev_binds <- TcM.getTcEvBinds ev_binds_var ; checkForCyclicBinds ev_binds +#endif + ; return res } where do_unification (tv,ty) = TcM.writeMetaTyVar tv ty - untouch = NoUntouchables is = emptyInert - wl = emptyWorkList -runTcS :: TcS a -- What to run - -> TcM (a, Bag EvBind) -runTcS tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; res <- runTcSWithEvBinds ev_binds_var tcs - ; ev_binds <- TcM.getTcEvBinds ev_binds_var - ; return (res, ev_binds) } - +#ifdef DEBUG checkForCyclicBinds :: Bag EvBind -> TcM () -#ifndef DEBUG -checkForCyclicBinds _ = return () -#else checkForCyclicBinds ev_binds | null cycles = return () @@ -994,50 +1083,27 @@ checkForCyclicBinds ev_binds edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds] #endif -doWithInert :: InertSet -> TcS a -> TcS a -doWithInert inert (TcS action) - = TcS $ \env -> do { new_inert_var <- TcM.newTcRef inert - ; action (env { tcs_inerts = new_inert_var }) } - -nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a -nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) +nestImplicTcS :: EvBindsVar -> Untouchables -> InertSet -> TcS a -> TcS a +nestImplicTcS ref inner_untch inerts (TcS thing_inside) = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds - , tcs_untch = (_outer_range, outer_tcs) - , tcs_count = count - , tcs_ic_depth = idepth - , tcs_inerts = inert_var - , tcs_worklist = wl_var - , tcs_implics = _impl_var } -> - do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs) - -- The inner_range should be narrower than the outer one - -- (thus increasing the set of untouchables) but - -- the inner Tcs-untouchables must be unioned with the - -- outer ones! - - -- Inherit the inerts from the outer scope - ; orig_inerts <- TcM.readTcRef inert_var - ; new_inert_var <- TcM.newTcRef orig_inerts - -- Inherit residual implications from outer scope (?) or create - -- fresh var? --- ; orig_implics <- TcM.readTcRef impl_var - ; new_implics_var <- TcM.newTcRef emptyBag - + , tcs_count = count } -> + do { new_inert_var <- TcM.newTcRef inerts ; let nest_env = TcSEnv { tcs_ev_binds = ref , tcs_ty_binds = ty_binds - , tcs_untch = inner_untch , tcs_count = count - , tcs_ic_depth = idepth+1 , tcs_inerts = new_inert_var - , tcs_worklist = wl_var - -- NB: worklist is going to be empty anyway, - -- so reuse the same ref cell - , tcs_implics = new_implics_var + , tcs_worklist = panic "nextImplicTcS: worklist" + , tcs_implics = panic "nextImplicTcS: implics" + -- NB: Both these are initialised by withWorkList } - ; res <- thing_inside nest_env + ; res <- TcM.setUntouchables inner_untch $ + thing_inside nest_env +#ifdef DEBUG -- Perform a check that the thing_inside did not cause cycles ; ev_binds <- TcM.getTcEvBinds ref ; checkForCyclicBinds ev_binds +#endif ; return res } @@ -1046,23 +1112,35 @@ recoverTcS (TcS recovery_code) (TcS thing_inside) = TcS $ \ env -> TcM.recoverM (recovery_code env) (thing_inside env) +nestTcS :: TcS a -> TcS a +-- Use the current untouchables, augmenting the current +-- evidence bindings, ty_binds, 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 + ; let nest_env = env { tcs_inerts = new_inert_var + , tcs_worklist = panic "nextImplicTcS: worklist" + , tcs_implics = panic "nextImplicTcS: implics" } + ; thing_inside nest_env } + tryTcS :: TcS a -> TcS a -- Like runTcS, but from within the TcS monad -- Completely afresh inerts and worklist, be careful! -- Moreover, we will simply throw away all the evidence generated. -tryTcS tcs - = TcS (\env -> - do { wl_var <- TcM.newTcRef emptyWorkList - ; is_var <- TcM.newTcRef emptyInert - - ; ty_binds_var <- TcM.newTcRef emptyVarEnv - ; ev_binds_var <- TcM.newTcEvBinds +tryTcS (TcS thing_inside) + = TcS $ \env -> + do { is_var <- TcM.newTcRef emptyInert + ; ty_binds_var <- TcM.newTcRef emptyVarEnv + ; ev_binds_var <- TcM.newTcEvBinds - ; let env1 = env { tcs_ev_binds = ev_binds_var - , tcs_ty_binds = ty_binds_var - , tcs_inerts = is_var - , tcs_worklist = wl_var } - ; unTcS tcs env1 }) + ; let nest_env = env { tcs_ev_binds = ev_binds_var + , tcs_ty_binds = ty_binds_var + , tcs_inerts = is_var + , tcs_worklist = panic "nextImplicTcS: worklist" + , tcs_implics = panic "nextImplicTcS: implics" } + ; thing_inside nest_env } -- Getters and setters of TcEnv fields -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1073,97 +1151,75 @@ getTcSInertsRef = TcS (return . tcs_inerts) getTcSWorkListRef :: TcS (IORef WorkList) getTcSWorkListRef = TcS (return . tcs_worklist) - getTcSInerts :: TcS InertSet getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) - -getTcSImplicsRef :: TcS (IORef (Bag Implication)) -getTcSImplicsRef = TcS (return . tcs_implics) - -getTcSImplics :: TcS (Bag Implication) -getTcSImplics = getTcSImplicsRef >>= wrapTcS . (TcM.readTcRef) - -getTcSWorkList :: TcS WorkList -getTcSWorkList = getTcSWorkListRef >>= wrapTcS . (TcM.readTcRef) - - -getTcSWorkListTvs :: TcS TyVarSet --- Return the variables of the worklist -getTcSWorkListTvs - = do { wl <- getTcSWorkList - ; return $ - cts_tvs (wl_eqs wl) `unionVarSet` cts_tvs (wl_funeqs wl) `unionVarSet` cts_tvs (wl_rest wl) } - where cts_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet - - updWorkListTcS :: (WorkList -> WorkList) -> TcS () updWorkListTcS f - = updWorkListTcS_return (\w -> ((),f w)) + = do { wl_var <- getTcSWorkListRef + ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) + ; let new_work = f wl_curr + ; wrapTcS (TcM.writeTcRef wl_var new_work) } updWorkListTcS_return :: (WorkList -> (a,WorkList)) -> TcS a +-- Process the work list, returning a depleted work list, +-- plus a value extracted from it (typically a work item removed from it) updWorkListTcS_return f = do { wl_var <- getTcSWorkListRef ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) ; 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 - ; implics <- wrapTcS (TcM.readTcRef impl_ref) - ; let new_implics = f implics - ; wrapTcS (TcM.writeTcRef impl_ref new_implics) } - -emitTcSImplication :: Implication -> TcS () -emitTcSImplication imp = updTcSImplics (consBag imp) + ; wrapTcS $ do { implics <- TcM.readTcRef impl_ref + ; TcM.writeTcRef impl_ref (f implics) } } - -emitFrozenError :: CtEvidence -> SubGoalDepth -> TcS () +emitInsoluble :: Ct -> TcS () -- Emits a non-canonical constraint that will stand for a frozen error in the inerts. -emitFrozenError fl depth - = do { traceTcS "Emit frozen error" (ppr (ctEvPred fl)) - ; inert_ref <- getTcSInertsRef - ; wrapTcS $ do - { inerts <- TcM.readTcRef inert_ref - ; let old_insols = inert_frozen inerts - ct = CNonCanonical { cc_ev = fl, cc_depth = depth } - inerts_new = inerts { inert_frozen = extendCts old_insols ct } - this_pred = ctEvPred fl - already_there = not (isWanted fl) && anyBag (eqType this_pred . ctPred) old_insols +emitInsoluble ct + = do { traceTcS "Emit insoluble" (ppr ct) + ; updInertTcS add_insol } + where + 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 } } + where + already_there = not (isWantedCt ct) && anyBag (eqType this_pred . ctPred) old_insols -- See Note [Do not add duplicate derived insolubles] - ; unless already_there $ - TcM.writeTcRef inert_ref inerts_new } } -instance HasDynFlags TcS where - getDynFlags = wrapTcS getDynFlags + this_pred = ctPred ct +getTcSImplicsRef :: TcS (IORef (Bag Implication)) +getTcSImplicsRef = TcS (return . tcs_implics) getTcEvBinds :: TcS EvBindsVar getTcEvBinds = TcS (return . tcs_ev_binds) -getFlatCache :: TcS CtTypeMap -getFlatCache = getTcSInerts >>= (return . unFamHeadMap . inert_flat_cache) - -updFlatCache :: Ct -> TcS () --- Pre: constraint is a flat family equation (equal to a flatten skolem) -updFlatCache flat_eq@(CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = xis }) - = modifyInertTcS upd_inert_cache - where upd_inert_cache is = ((), is { inert_flat_cache = FamHeadMap new_fc }) - where new_fc = alterTM pred_key upd_cache fc - fc = unFamHeadMap $ inert_flat_cache is - pred_key = mkTyConApp tc xis - upd_cache (Just ct) | cc_ev ct `canSolve` fl = Just ct - upd_cache (Just _ct) = Just flat_eq - upd_cache Nothing = Just flat_eq -updFlatCache other_ct = pprPanic "updFlatCache: non-family constraint" $ - ppr other_ct - +getUntouchables :: TcS Untouchables +getUntouchables = wrapTcS TcM.getUntouchables -getUntouchables :: TcS TcsUntouchables -getUntouchables = TcS (return . tcs_untch) +getFlattenSkols :: TcS [TcTyVar] +getFlattenSkols = do { is <- getTcSInerts; return (inert_fsks is) } getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType))) getTcSTyBinds = TcS (return . tcs_ty_binds) @@ -1180,7 +1236,8 @@ setWantedTyBind :: TcTyVar -> TcType -> TcS () -- Add a type binding -- We never do this twice! setWantedTyBind tv ty - = do { ref <- getTcSTyBinds + = ASSERT2( isMetaTyVar tv, ppr tv ) + do { ref <- getTcSTyBinds ; wrapTcS $ do { ty_binds <- TcM.readTcRef ref ; when debugIsOn $ @@ -1188,17 +1245,11 @@ setWantedTyBind tv ty 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 (extendVarEnv ty_binds tv (tv,ty)) } } - - \end{code} \begin{code} -warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS () -warnTcS loc warn_if doc - | warn_if = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc - | otherwise = return () - getDefaultInfo :: TcS ([Type], (Bool, Bool)) getDefaultInfo = wrapTcS TcM.tcGetDefaultTys @@ -1220,7 +1271,7 @@ getGblEnv = wrapTcS $ TcM.getGblEnv -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -checkWellStagedDFun :: PredType -> DFunId -> WantedLoc -> TcS () +checkWellStagedDFun :: PredType -> DFunId -> CtLoc -> TcS () checkWellStagedDFun pred dfun_id loc = wrapTcS $ TcM.setCtLoc loc $ do { use_stage <- TcM.getStage @@ -1232,26 +1283,26 @@ checkWellStagedDFun pred dfun_id loc pprEq :: TcType -> TcType -> SDoc pprEq ty1 ty2 = pprType $ mkEqPred ty1 ty2 -isTouchableMetaTyVar :: TcTyVar -> TcS Bool -isTouchableMetaTyVar tv +isTouchableMetaTyVarTcS :: TcTyVar -> TcS Bool +isTouchableMetaTyVarTcS tv = do { untch <- getUntouchables - ; return $ isTouchableMetaTyVar_InRange untch tv } - -isTouchableMetaTyVar_InRange :: TcsUntouchables -> TcTyVar -> Bool -isTouchableMetaTyVar_InRange (untch,untch_tcs) tv - = ASSERT2 ( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs) - -- See Note [Touchable meta type variables] - MetaTv {} -> inTouchableRange untch tv && not (tv `elemVarSet` untch_tcs) - _ -> False - - + ; return $ isTouchableMetaTyVar untch tv } + +isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) +isFilledMetaTyVar_maybe tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- wrapTcS (TcM.readTcRef ref) + ; case cts of + Indirect ty -> return (Just ty) + Flexi -> return Nothing } + _ -> return Nothing \end{code} Note [Do not add duplicate derived insolubles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we do want to add an insoluble (Int ~ Bool) even if there is one +In general we *do* want to add an insoluble (Int ~ Bool) even if there is one such there already, because they may come from distinct call sites. But for *derived* insolubles, we only want to report each one once. Why? @@ -1285,7 +1336,7 @@ which we have simplified to: For some reason, e.g. because we floated an equality somewhere else, we might try to re-solve this implication. If we do not do a -keepWanted, then we will end up trying to solve the following +dropDerivedWC, then we will end up trying to solve the following constraints the second time: (D [c] c) [W] @@ -1296,34 +1347,47 @@ which will result in two Deriveds to end up in the insoluble set: wc_flat = D [c] c [W] wc_insols = (c ~ [c]) [D], (c ~ [c]) [D] -Note [Touchable meta type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Meta type variables allocated *by the constraint solver itself* are always -touchable. Example: - instance C a b => D [a] where... -if we use this instance declaration we "make up" a fresh meta type -variable for 'b', which we must later guess. (Perhaps C has a -functional dependency.) But since we aren't in the constraint *generator* -we can't allocate a Unique in the touchable range for this implication -constraint. Instead, we mark it as a "TcsTv", which makes it always-touchable. \begin{code} -- Flatten skolems -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -newFlattenSkolemTy :: TcType -> TcS TcType -newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty - -newFlattenSkolemTyVar :: TcType -> TcS TcTyVar -newFlattenSkolemTyVar ty +newFlattenSkolem :: CtFlavour + -> 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 Given fam_ty = do { tv <- wrapTcS $ do { uniq <- TcM.newUnique ; let name = TcM.mkTcTyVarName uniq (fsLit "f") - ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } + ; return $ mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty) } ; traceTcS "New Flatten Skolem Born" $ - ppr tv <+> text "[:= " <+> ppr ty <+> text "]" - ; return tv } + ppr tv <+> text "[:= " <+> ppr fam_ty <+> text "]" + + ; let rhs_ty = mkTyVarTy tv + ctev = CtGiven { ctev_pred = mkTcEqPred fam_ty rhs_ty + , ctev_evtm = EvCoercion (mkTcReflCo fam_ty) } + ; updInertTcS $ \ is@(IS { inert_fsks = fsks }) -> + extendFlatCache fam_ty ctev rhs_ty + is { inert_fsks = tv : fsks } + + ; return (ctev, rhs_ty) } + +newFlattenSkolem _ fam_ty -- Wanted or Derived: make new unification variable + = do { rhs_ty <- newFlexiTcSTy (typeKind fam_ty) + ; ctev <- newWantedEvVarNC (mkTcEqPred fam_ty rhs_ty) + -- NC (no-cache) version because we've already + -- looked in the solved goals an inerts (lookupFlatEqn) + ; updInertTcS $ extendFlatCache fam_ty ctev rhs_ty + ; return (ctev, rhs_ty) } + +extendFlatCache :: TcType -> CtEvidence -> TcType -> InertSet -> InertSet +extendFlatCache + | opt_NoFlatCache + = \ _ _ _ is -> is + | otherwise + = \ fam_ty ctev rhs_ty is@(IS { inert_flat_cache = fc }) -> + is { inert_flat_cache = insertFamHead fc fam_ty (ctev,rhs_ty) } -- Instantiations -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1347,41 +1411,31 @@ instDFunType dfun_id mb_inst_tys ; return (ty : tys, phi) } go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr mb_inst_tys) +newFlexiTcSTy :: Kind -> TcS TcType +newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) + +cloneMetaTyVar :: TcTyVar -> TcS TcTyVar +cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) + instFlexiTcS :: [TKVar] -> TcS (TvSubst, [TcType]) --- Like TcM.instMetaTyVar but the variable that is created is --- always touchable; we are supposed to guess its instantiation. --- See Note [Touchable meta type variables] instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs) where - inst_one subst tv = do { ty' <- instFlexiTcSHelper (tyVarName tv) - (substTy subst (tyVarKind tv)) - ; return (extendTvSubst subst tv ty', ty') } - -newFlexiTcSTy :: Kind -> TcS TcType -newFlexiTcSTy knd - = wrapTcS $ - do { uniq <- TcM.newUnique - ; ref <- TcM.newMutVar Flexi - ; let name = TcM.mkTcTyVarName uniq (fsLit "uf") - ; return $ mkTyVarTy (mkTcTyVar name knd (MetaTv TcsTv ref)) } - -isFlexiTcsTv :: TyVar -> Bool -isFlexiTcsTv tv - | not (isTcTyVar tv) = False - | MetaTv TcsTv _ <- tcTyVarDetails tv = True - | otherwise = False + inst_one subst tv + = do { ty' <- instFlexiTcSHelper (tyVarName tv) + (substTy subst (tyVarKind tv)) + ; return (extendTvSubst subst tv ty', ty') } instFlexiTcSHelper :: Name -> Kind -> TcM TcType -instFlexiTcSHelper tvname tvkind +instFlexiTcSHelper tvname kind = do { uniq <- TcM.newUnique - ; ref <- TcM.newMutVar Flexi + ; details <- TcM.newMetaDetails TauTv ; let name = setNameUnique tvname uniq - kind = tvkind - ; return (mkTyVarTy (mkTcTyVar name kind (MetaTv TcsTv ref))) } + ; return (mkTyVarTy (mkTcTyVar name kind details)) } instFlexiTcSHelperTcS :: Name -> Kind -> TcS TcType instFlexiTcSHelperTcS n k = wrapTcS (instFlexiTcSHelper n k) + -- Creating and setting evidence variables and CtFlavors -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1415,41 +1469,43 @@ setEvBind the_ev tm ; tc_evbinds <- getTcEvBinds ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm } -newGivenEvVar :: GivenLoc -> TcPredType -> EvTerm -> TcS CtEvidence +newGivenEvVar :: TcPredType -> EvTerm -> TcS CtEvidence -- Make a new variable of the given PredType, -- immediately bind it to the given term -- and return its CtEvidence -newGivenEvVar gloc pred rhs +newGivenEvVar pred rhs = do { new_ev <- wrapTcS $ TcM.newEvVar pred ; setEvBind new_ev rhs - ; return (Given { ctev_gloc = gloc, ctev_pred = pred, ctev_evtm = EvId new_ev }) } - -newWantedEvVar :: WantedLoc -> TcPredType -> TcS MaybeNew -newWantedEvVar loc pty - = do { is <- getTcSInerts - ; case lookupInInerts is pty of + ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev }) } + +newWantedEvVarNC :: TcPredType -> TcS CtEvidence +-- Don't look up in the solved/inerts; we know it's not there +newWantedEvVarNC pty + = do { new_ev <- wrapTcS $ TcM.newEvVar pty + ; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev })} + +newWantedEvVar :: TcPredType -> TcS MaybeNew +newWantedEvVar 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)) } - _ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty - ; traceTcS "newWantedEvVar/cache miss" $ ppr new_ev - ; let ctev = Wanted { ctev_wloc = loc - , ctev_pred = pty - , ctev_evar = new_ev } + _ -> do { ctev <- newWantedEvVarNC pty + ; traceTcS "newWantedEvVar/cache miss" $ ppr ctev ; return (Fresh ctev) } } -newDerived :: WantedLoc -> TcPredType -> TcS (Maybe CtEvidence) +newDerived :: TcPredType -> TcS (Maybe CtEvidence) -- Returns Nothing if cached, -- Just pred if not cached -newDerived loc pty - = do { is <- getTcSInerts - ; case lookupInInerts is pty of - Just {} -> return Nothing - _ -> return (Just Derived { ctev_wloc = loc - , ctev_pred = pty }) } - -instDFunConstraints :: WantedLoc -> TcThetaType -> TcS [MaybeNew] -instDFunConstraints wl = mapM (newWantedEvVar wl) +newDerived pty + = do { mb_ct <- lookupInInerts pty + ; return (case mb_ct of + Just {} -> Nothing + Nothing -> Just (CtDerived { ctev_pred = pty })) } + +instDFunConstraints :: TcThetaType -> TcS [MaybeNew] +instDFunConstraints = mapM newWantedEvVar \end{code} @@ -1493,34 +1549,23 @@ See Note [Coercion evidence terms] in TcEvidence. \begin{code} -xCtFlavor :: CtEvidence -- Original flavor +xCtFlavor :: CtEvidence -- Original flavor -> [TcPredType] -- New predicate types -> XEvTerm -- Instructions about how to manipulate evidence -> TcS [CtEvidence] -xCtFlavor = xCtFlavor_cache True -xCtFlavor_cache :: Bool -- True = if wanted add to the solved bag! - -> CtEvidence -- Original flavor - -> [TcPredType] -- New predicate types - -> XEvTerm -- Instructions about how to manipulate evidence - -> TcS [CtEvidence] - -xCtFlavor_cache _ (Given { ctev_gloc = gl, ctev_evtm = tm }) ptys xev +xCtFlavor (CtGiven { ctev_evtm = tm }) ptys xev = ASSERT( equalLength ptys (ev_decomp xev tm) ) - zipWithM (newGivenEvVar gl) ptys (ev_decomp xev tm) + zipWithM newGivenEvVar ptys (ev_decomp xev tm) -- See Note [Bind new Givens immediately] -xCtFlavor_cache cache ctev@(Wanted { ctev_wloc = wl, ctev_evar = evar }) ptys xev - = do { new_evars <- mapM (newWantedEvVar wl) ptys +xCtFlavor ctev@(CtWanted { ctev_evar = evar }) ptys xev + = do { new_evars <- mapM newWantedEvVar ptys ; setEvBind evar (ev_comp xev (getEvTerms new_evars)) - - -- Add the now-solved wanted constraint to the cache - ; when cache $ addToSolved ctev - ; return (freshGoals new_evars) } -xCtFlavor_cache _ (Derived { ctev_wloc = wl }) ptys _xev - = do { ders <- mapM (newDerived wl) ptys +xCtFlavor (CtDerived {}) ptys _xev + = do { ders <- mapM newDerived ptys ; return (catMaybes ders) } ----------------------------- @@ -1528,9 +1573,12 @@ rewriteCtFlavor :: CtEvidence -> TcPredType -- new predicate -> TcCoercion -- new ~ old -> TcS (Maybe CtEvidence) +-- Returns Just new_fl 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_fl {- rewriteCtFlavor old_fl new_pred co -Main purpose: create a new identity (flavor) for new_pred; +Main purpose: create new evidence for new_pred; unless new_pred is cached already * Returns a new_fl : new_pred, with same wanted/given/derived flag as old_fl * If old_fl was wanted, create a binding for old_fl, in terms of new_fl @@ -1546,47 +1594,36 @@ Main purpose: create a new identity (flavor) for new_pred; Given Already in inert Nothing Not Just new_evidence - - Solved NEVER HAPPENS -} -rewriteCtFlavor = rewriteCtFlavor_cache True --- Returns Just new_fl 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_fl - -rewriteCtFlavor_cache :: Bool - -> CtEvidence - -> TcPredType -- new predicate - -> TcCoercion -- new ~ old - -> TcS (Maybe CtEvidence) -- If derived, don't even look at the coercion -- NB: this allows us to sneak away with ``error'' thunks for -- coercions that come from derived ids (which don't exist!) -rewriteCtFlavor_cache _cache (Derived { ctev_wloc = wl }) pty_new _co - = newDerived wl pty_new + +rewriteCtFlavor (CtDerived {}) pty_new _co + = newDerived pty_new -rewriteCtFlavor_cache _cache (Given { ctev_gloc = gl, ctev_evtm = old_tm }) pty_new co - = do { new_ev <- newGivenEvVar gl pty_new new_tm -- See Note [Bind new Givens immediately] +rewriteCtFlavor (CtGiven { ctev_evtm = old_tm }) pty_new co + = do { new_ev <- newGivenEvVar pty_new new_tm -- See Note [Bind new Givens immediately] ; return (Just new_ev) } where - new_tm = mkEvCast old_tm (mkTcSymCo co) -- mkEvCase optimises ReflCo + new_tm = mkEvCast old_tm (mkTcSymCo co) -- mkEvCast optimises ReflCo -rewriteCtFlavor_cache cache ctev@(Wanted { ctev_wloc = wl, ctev_evar = evar, ctev_pred = pty_old }) pty_new co - | isTcReflCo co -- If just reflexivity then you may re-use the same variable - = return (Just (if pty_old `eqType` pty_new +rewriteCtFlavor ctev@(CtWanted { ctev_evar = evar, ctev_pred = old_pred }) + new_pred co + | isTcReflCo co -- If just reflexivity then you may re-use the same variable + = return (Just (if old_pred `eqType` new_pred then ctev - else ctev { ctev_pred = pty_new })) - -- If the old and new types compare equal (eqType looks through synonyms) + else ctev { ctev_pred = new_pred })) + -- Even if the coercion is Refl, it might reflect the result of unification alpha := ty + -- so old_pred and new_pred might not *look* the same, and it's vital to proceed from + -- now on using new_pred. + -- However, if they *do* look the same, we'd prefer to stick with old_pred -- then retain the old type, so that error messages come out mentioning synonyms | otherwise - = do { new_evar <- newWantedEvVar wl pty_new + = do { new_evar <- newWantedEvVar new_pred ; setEvBind evar (mkEvCast (getEvTerm new_evar) co) - - -- Add the now-solved wanted constraint to the cache - ; when cache $ addToSolved ctev - ; case new_evar of Fresh ctev -> return (Just ctev) _ -> return Nothing } @@ -1641,7 +1678,7 @@ matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args -- Deferring forall equalities as implications -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -deferTcSForAllEq :: (WantedLoc,EvVar) -- Original wanted equality flavor +deferTcSForAllEq :: (CtLoc,EvVar) -- Original wanted equality flavor -> ([TyVar],TcType) -- ForAll tvs1 body1 -> ([TyVar],TcType) -- ForAll tvs2 body2 -> TcS () @@ -1653,52 +1690,32 @@ deferTcSForAllEq (loc,orig_ev) (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 (mkTcEqPred phi1 phi2) + ; mev <- newWantedEvVar (mkTcEqPred phi1 phi2) ; 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_ct = mkNonCanonical loc ctev new_co = evTermCoercion (ctEvTerm ctev) - ; lcl_env <- wrapTcS $ TcM.getLclTypeEnv - ; loc <- wrapTcS $ TcM.getCtLoc skol_info + new_untch = pushUntouchables (tcl_untch env) ; let wc = WC { wc_flat = singleCt new_ct , wc_impl = emptyBag , wc_insol = emptyCts } - imp = Implic { ic_untch = all_untouchables - , ic_env = lcl_env + imp = Implic { ic_untch = new_untch , ic_skols = skol_tvs + , ic_fsks = [] , ic_given = [] , ic_wanted = wc , ic_insol = False , ic_binds = ev_binds_var - , ic_loc = loc } + , ic_env = env + , ic_info = skol_info } ; updTcSImplics (consBag imp) ; return (TcLetCo ev_binds new_co) } ; setEvBind orig_ev $ EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs) } - where all_untouchables = TouchableRange u u - u = idUnique orig_ev -- HACK: empty range - -\end{code} - - - --- Rewriting with respect to the inert equalities --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -\begin{code} -getInertEqs :: TcS (TyVarEnv Ct, InScopeSet) -getInertEqs = do { inert <- getTcSInerts - ; let ics = inert_cans inert - ; return (inert_eqs ics, inert_eq_tvs ics) } - -getCtCoercion :: EvBindMap -> Ct -> TcCoercion --- Precondition: A CTyEqCan which is either Wanted or Given, never Derived or Solved! -getCtCoercion _bs ct - = ASSERT( not (isDerivedCt ct) ) - evTermCoercion (ctEvTerm (ctEvidence ct)) \end{code} - diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index c36ee43f83..c0ff59d793 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -9,11 +9,13 @@ module TcSimplify( simplifyInfer, simplifyAmbiguityCheck, simplifyDefault, simplifyDeriv, - simplifyRule, simplifyTop, simplifyInteractive + simplifyRule, simplifyTop, simplifyInteractive, + solveWantedsTcM ) where #include "HsVersions.h" +import TcRnTypes import TcRnMonad import TcErrors import TcMType @@ -21,8 +23,8 @@ import TcType import TcSMonad import TcInteract import Inst -import Unify ( niFixTvSubst, niSubstTvSet ) -import Type ( classifyPredType, PredTree(..), isIPPred_maybe ) +import Type ( classifyPredType, PredTree(..), getClassPredTys_maybe ) +import Class ( Class ) import Var import Unique import VarSet @@ -37,12 +39,9 @@ import PrelInfo import PrelNames import Class ( classKey ) import BasicTypes ( RuleName ) -import Control.Monad ( when ) import Outputable import FastString import TrieMap () -- DV: for now -import DynFlags -import Data.Maybe ( mapMaybe ) \end{code} @@ -52,53 +51,45 @@ import Data.Maybe ( mapMaybe ) * * ********************************************************************************* - \begin{code} - - simplifyTop :: WantedConstraints -> TcM (Bag EvBind) -- Simplify top-level constraints -- Usually these will be implications, -- but when there is nothing to quantify we don't wrap -- in a degenerate implication, so we do that here instead -simplifyTop wanteds - = do { ev_binds_var <- newTcEvBinds - - ; zonked_wanteds <- zonkWC wanteds - ; wc_first_go <- solveWantedsWithEvBinds ev_binds_var zonked_wanteds - ; cts <- applyTyVarDefaulting wc_first_go - -- See Note [Top-level Defaulting Plan] - - ; let wc_for_loop = wc_first_go { wc_flat = wc_flat wc_first_go `unionBags` cts } - - ; traceTc "simpl_top_loop {" $ text "zonked_wc =" <+> ppr zonked_wanteds - ; simpl_top_loop ev_binds_var wc_for_loop } +simplifyTop wanteds + = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds + ; ev_binds_var <- newTcEvBinds + ; zonked_final_wc <- solveWantedsTcMWithEvBinds ev_binds_var wanteds simpl_top + ; binds1 <- TcRnMonad.getTcEvBinds ev_binds_var + ; traceTc "End simplifyTop }" empty + + ; traceTc "reportUnsolved {" empty + ; binds2 <- reportUnsolved zonked_final_wc + ; traceTc "reportUnsolved }" empty + + ; return (binds1 `unionBags` binds2) } + + where + -- See Note [Top-level Defaulting Plan] + simpl_top :: WantedConstraints -> TcS WantedConstraints + simpl_top wanteds + = do { wc_first_go <- nestTcS (solve_wanteds_and_drop wanteds) + ; applyTyVarDefaulting wc_first_go + ; simpl_top_loop wc_first_go } - where simpl_top_loop ev_binds_var wc - | isEmptyWC wc - = do { traceTc "simpl_top_loop }" empty - ; TcRnMonad.getTcEvBinds ev_binds_var } - | otherwise - = do { wc_residual <- solveWantedsWithEvBinds ev_binds_var wc - ; let wc_flat_approximate = approximateWC wc_residual - ; (dflt_eqs,_unused_bind) <- runTcS $ - applyDefaultingRules wc_flat_approximate - -- See Note [Top-level Defaulting Plan] - ; if isEmptyBag dflt_eqs then - do { traceTc "simpl_top_loop }" empty - ; report_and_finish ev_binds_var wc_residual } - else - simpl_top_loop ev_binds_var $ - wc_residual { wc_flat = wc_flat wc_residual `unionBags` dflt_eqs } } - - report_and_finish ev_binds_var wc_residual - = do { eb1 <- TcRnMonad.getTcEvBinds ev_binds_var - ; traceTc "reportUnsolved {" empty - -- See Note [Deferring coercion errors to runtime] - ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors - ; eb2 <- reportUnsolved runtimeCoercionErrors wc_residual - ; traceTc "reportUnsolved }" empty - ; return (eb1 `unionBags` eb2) } + simpl_top_loop wc + | isEmptyWC wc + = return wc + | otherwise + = do { wc_residual <- nestTcS (solve_wanteds_and_drop wc) + ; let wc_flat_approximate = approximateWC wc_residual + ; something_happened <- applyDefaultingRules wc_flat_approximate + -- See Note [Top-level Defaulting Plan] + ; if something_happened then + simpl_top_loop wc_residual + else + return wc_residual } \end{code} Note [Top-level Defaulting Plan] @@ -148,7 +139,7 @@ More details in Note [DefaultTyVar]. simplifyAmbiguityCheck :: Name -> WantedConstraints -> TcM (Bag EvBind) simplifyAmbiguityCheck name wanteds = traceTc "simplifyAmbiguityCheck" (text "name =" <+> ppr name) >> - simplifyTop wanteds -- NB: must be simplifyTop not simplifyCheck, so that we + simplifyTop wanteds -- NB: must be simplifyTop so that we -- do ambiguity resolution. -- See Note [Impedence matching] in TcBinds. @@ -164,7 +155,16 @@ simplifyDefault :: ThetaType -- Wanted; has no type variables in it simplifyDefault theta = do { traceTc "simplifyInteractive" empty ; wanted <- newFlatWanteds DefaultOrigin theta - ; _ignored_ev_binds <- simplifyCheck (mkFlatWC wanted) + ; (unsolved, _binds) <- solveWantedsTcM (mkFlatWC wanted) + + ; traceTc "reportUnsolved {" empty + -- See Note [Deferring coercion errors to runtime] + ; reportAllUnsolved unsolved + -- Postcondition of solveWantedsTcM is that returned + -- constraints are zonked. So Precondition of reportUnsolved + -- is true. + ; traceTc "reportUnsolved }" empty + ; return () } \end{code} @@ -200,7 +200,8 @@ simplifyDeriv orig pred tvs theta ; traceTc "simplifyDeriv" $ vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ] ; (residual_wanted, _ev_binds1) - <- solveWanteds (mkFlatWC wanted) + <- solveWantedsTcM (mkFlatWC wanted) + -- Post: residual_wanted are already zonked ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) -- See Note [Exotic derived instance contexts] @@ -215,7 +216,7 @@ simplifyDeriv orig pred tvs theta -- We never want to defer these errors because they are errors in the -- compiler! Hence the `False` below - ; _ev_binds2 <- reportUnsolved False (residual_wanted { wc_flat = bad }) + ; reportAllUnsolved (residual_wanted { wc_flat = bad }) ; let min_theta = mkMinimalBySCs (bagToList good) ; return (substTheta subst_skol min_theta) } @@ -320,14 +321,14 @@ simplifyInfer :: Bool -> Bool -- Apply monomorphism restriction -> [(Name, TcTauType)] -- Variables to be generalised, -- and their tau-types - -> (Untouchables, WantedConstraints) + -> WantedConstraints -> TcM ([TcTyVar], -- Quantify over these type variables [EvVar], -- ... and these constraints Bool, -- The monomorphism restriction did something -- so the results type is not as general as -- it could be TcEvBinds) -- ... binding these evidence variables -simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) +simplifyInfer _top_lvl apply_mr name_taus wanteds | isEmptyWC wanteds = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; zonked_taus <- zonkTcTypes (map snd name_taus) @@ -338,20 +339,16 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) ; return (qtvs, [], False, emptyTcEvBinds) } | otherwise - = do { runtimeCoercionErrors <- doptM Opt_DeferTypeErrors - ; gbl_tvs <- tcGetGlobalTyVars - ; zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus)) - ; zonked_wanteds <- zonkWC wanteds + = do { zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus)) + ; ev_binds_var <- newTcEvBinds ; traceTc "simplifyInfer {" $ vcat [ ptext (sLit "names =") <+> ppr (map fst name_taus) , ptext (sLit "taus =") <+> ppr (map snd name_taus) , ptext (sLit "tau_tvs (zonked) =") <+> ppr zonked_tau_tvs - , ptext (sLit "gbl_tvs =") <+> ppr gbl_tvs , ptext (sLit "closed =") <+> ppr _top_lvl , ptext (sLit "apply_mr =") <+> ppr apply_mr - , ptext (sLit "untch =") <+> ppr untch - , ptext (sLit "wanted =") <+> ppr zonked_wanteds + , ptext (sLit "(unzonked) wanted =") <+> ppr wanteds ] -- Historical note: Before step 2 we used to have a @@ -368,60 +365,63 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) -- calling solveWanteds will side-effect their evidence -- bindings, so we can't just revert to the input -- constraint. - ; ev_binds_var <- newTcEvBinds - ; wanted_transformed <- solveWantedsWithEvBinds ev_binds_var zonked_wanteds - - -- Step 3) Fail fast if there is an insoluble constraint, - -- unless we are deferring errors to runtime - ; when (not runtimeCoercionErrors && insolubleWC wanted_transformed) $ - do { _ev_binds <- reportUnsolved False wanted_transformed; failM } + ; wanted_transformed <- solveWantedsTcMWithEvBinds ev_binds_var wanteds $ + solve_wanteds_and_drop + -- Post: wanted_transformed are zonked -- Step 4) Candidates for quantification are an approximation of wanted_transformed - ; let quant_candidates = approximateWC wanted_transformed -- NB: Already the fixpoint of any unifications that may have happened -- NB: We do not do any defaulting when inferring a type, this can lead -- to less polymorphic types, see Note [Default while Inferring] - -- NB: quant_candidates here are wanted or derived, we filter the wanteds later, anyway -- Step 5) Minimize the quantification candidates - ; (quant_candidates_transformed, _extra_binds) - <- solveWanteds $ WC { wc_flat = quant_candidates - , wc_impl = emptyBag - , wc_insol = emptyBag } - -- Step 6) Final candidates for quantification - ; let final_quant_candidates :: [PredType] - final_quant_candidates = map ctPred $ bagToList $ - keepWanted (wc_flat quant_candidates_transformed) - -- NB: Already the fixpoint of any unifications that may have happened + -- We discard bindings, insolubles etc, because all we are + -- care aout it + + ; (quant_pred_candidates, _extra_binds) + <- if insolubleWC wanted_transformed + then return ([], emptyBag) -- See Note [Quantification with errors] + else runTcS $ + do { let quant_candidates = approximateWC wanted_transformed + ; traceTcS "simplifyWithApprox" $ + text "quant_candidates = " <+> ppr quant_candidates + ; promoteTyVars quant_candidates + ; _implics <- solveInteract quant_candidates + ; (flats, _insols) <- getInertUnsolved + -- NB: Dimitrios is slightly worried that we will get + -- family equalities (F Int ~ alpha) in the quantification + -- candidates, as we have performed no further unflattening + -- at this point. Nothing bad, but inferred contexts might + -- look complicated. + ; return (map ctPred $ filter isWantedCt (bagToList flats)) } + + -- NB: quant_pred_candidates is already the fixpoint of any + -- unifications that may have happened ; gbl_tvs <- tcGetGlobalTyVars -- TODO: can we just use untch instead of gbl_tvs? ; zonked_tau_tvs <- zonkTyVarsAndFV zonked_tau_tvs - ; traceTc "simplifyWithApprox" $ - vcat [ ptext (sLit "final_quant_candidates =") <+> ppr final_quant_candidates - , ptext (sLit "gbl_tvs=") <+> ppr gbl_tvs - , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs ] - ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs - poly_qtvs = growThetaTyVars final_quant_candidates init_tvs + poly_qtvs = growThetaTyVars quant_pred_candidates init_tvs `minusVarSet` gbl_tvs - pbound = filter (quantifyPred poly_qtvs) final_quant_candidates + pbound = filter (quantifyPred poly_qtvs) quant_pred_candidates - ; traceTc "simplifyWithApprox" $ - vcat [ ptext (sLit "pbound =") <+> ppr pbound - , ptext (sLit "init_qtvs =") <+> ppr init_tvs - , ptext (sLit "poly_qtvs =") <+> ppr poly_qtvs ] - -- Monomorphism restriction - ; let mr_qtvs = init_tvs `minusVarSet` constrained_tvs - constrained_tvs = tyVarsOfTypes final_quant_candidates + mr_qtvs = init_tvs `minusVarSet` constrained_tvs + constrained_tvs = tyVarsOfTypes quant_pred_candidates mr_bites = apply_mr && not (null pbound) - (qtvs, bound) - | mr_bites = (mr_qtvs, []) - | otherwise = (poly_qtvs, pbound) + (qtvs, bound) | mr_bites = (mr_qtvs, []) + | otherwise = (poly_qtvs, pbound) + ; 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 "init_qtvs =") <+> ppr init_tvs + , ptext (sLit "poly_qtvs =") <+> ppr poly_qtvs ] ; if isEmptyVarSet qtvs && null bound then do { traceTc "} simplifyInfer/no quantification" empty @@ -446,30 +446,39 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) -- Step 7) Emit an implication ; minimal_bound_ev_vars <- mapM TcMType.newEvVar minimal_flat_preds - ; lcl_env <- getLclTypeEnv - ; gloc <- getCtLoc skol_info - ; let implic = Implic { ic_untch = untch - , ic_env = lcl_env + ; lcl_env <- TcRnMonad.getLclEnv + ; let implic = Implic { ic_untch = pushUntouchables (tcl_untch lcl_env) , ic_skols = qtvs_to_return + , 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 , ic_binds = ev_binds_var - , ic_loc = gloc } + , ic_info = skol_info + , ic_env = lcl_env } ; 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_to_return - , ptext (sLit "spb =") <+> ppr final_quant_candidates + , ptext (sLit "spb =") <+> ppr quant_pred_candidates , ptext (sLit "bound =") <+> ppr bound ] ; return ( qtvs_to_return, minimal_bound_ev_vars , mr_bites, TcEvBinds ev_binds_var) } } - where \end{code} +Note [Quantification with errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find that the RHS of the definition has some absolutely-insoluble +constraints, we abandon all attempts to find a context to quantify +over, and instead make the function fully-polymorphic in whatever +type we have found. For two reasons + a) Minimise downstream errors + b) Avoid spurious errors from this function + Note [Default while Inferring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -509,7 +518,6 @@ we don't do it for now. Note [Minimize by Superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - When we quantify over a constraint, in simplifyInfer we need to quantify over a constraint that is minimal in some sense: For instance, if the final wanted constraint is (Eq alpha, Ord alpha), @@ -518,29 +526,6 @@ from superclass selection from Ord alpha. This minimization is what mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint to check the original wanted. -\begin{code} -approximateWC :: WantedConstraints -> Cts --- Postcondition: Wanted or Derived Cts -approximateWC wc = float_wc emptyVarSet wc - where - float_wc :: TcTyVarSet -> WantedConstraints -> Cts - float_wc skols (WC { wc_flat = flat, wc_impl = implic }) = floats1 `unionBags` floats2 - where floats1 = do_bag (float_flat skols) flat - floats2 = do_bag (float_implic skols) implic - - float_implic :: TcTyVarSet -> Implication -> Cts - float_implic skols imp - = float_wc (skols `extendVarSetList` ic_skols imp) (ic_wanted imp) - - float_flat :: TcTyVarSet -> Ct -> Cts - float_flat skols ct - | tyVarsOfCt ct `disjointVarSet` skols - = singleCt ct - | otherwise = emptyCts - - do_bag :: (a -> Bag c) -> Bag a -> Bag c - do_bag f = foldrBag (unionBags.f) emptyBag -\end{code} Note [Avoid unecessary constraint simplification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -596,16 +581,13 @@ simplifyRule :: RuleName -> TcM ([EvVar], WantedConstraints) -- LHS evidence varaibles -- See Note [Simplifying RULE constraints] in TcRule simplifyRule name lhs_wanted rhs_wanted - = do { zonked_all <- zonkWC (lhs_wanted `andWC` rhs_wanted) - ; let doc = ptext (sLit "LHS of rule") <+> doubleQuotes (ftext name) - - -- We allow ourselves to unify environment + = do { -- We allow ourselves to unify environment -- variables: runTcS runs with NoUntouchables - ; (resid_wanted, _) <- solveWanteds zonked_all - - ; zonked_lhs <- zonkWC lhs_wanted + (resid_wanted, _) <- solveWantedsTcM (lhs_wanted `andWC` rhs_wanted) + -- Post: these are zonked and unflattened - ; let (q_cts, non_q_cts) = partitionBag quantify_me (wc_flat zonked_lhs) + ; zonked_lhs_flats <- zonkCts (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 | otherwise = quantify_normal @@ -619,12 +601,12 @@ simplifyRule name lhs_wanted rhs_wanted = True ; traceTc "simplifyRule" $ - vcat [ doc - , text "zonked_lhs" <+> ppr zonked_lhs + vcat [ ptext (sLit "LHS of rule") <+> doubleQuotes (ftext name) + , text "zonked_lhs_flats" <+> ppr zonked_lhs_flats , text "q_cts" <+> ppr q_cts ] ; return ( map (ctEvId . ctEvidence) (bagToList q_cts) - , zonked_lhs { wc_flat = non_q_cts }) } + , lhs_wanted { wc_flat = non_q_cts }) } \end{code} @@ -634,43 +616,8 @@ simplifyRule name lhs_wanted rhs_wanted * * *********************************************************************************** -\begin{code} -simplifyCheck :: WantedConstraints -- Wanted - -> TcM (Bag EvBind) --- Solve a single, top-level implication constraint --- e.g. typically one created from a top-level type signature --- f :: forall a. [a] -> [a] --- f x = rhs --- We do this even if the function has no polymorphism: --- g :: Int -> Int - --- g y = rhs --- (whereas for *nested* bindings we would not create --- an implication constraint for g at all.) --- --- Fails if can't solve something in the input wanteds -simplifyCheck wanteds - = do { wanteds <- zonkWC wanteds - - ; traceTc "simplifyCheck {" (vcat - [ ptext (sLit "wanted =") <+> ppr wanteds ]) - - ; (unsolved, eb1) <- solveWanteds wanteds - - ; traceTc "simplifyCheck }" $ ptext (sLit "unsolved =") <+> ppr unsolved - - ; traceTc "reportUnsolved {" empty - -- See Note [Deferring coercion errors to runtime] - ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors - ; eb2 <- reportUnsolved runtimeCoercionErrors unsolved - ; traceTc "reportUnsolved }" empty - - ; return (eb1 `unionBags` eb2) } -\end{code} - Note [Deferring coercion errors to runtime] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - While developing, sometimes it is desirable to allow compilation to succeed even if there are type errors in the code. Consider the following case: @@ -706,61 +653,88 @@ in TcErrors (with ErrEnv). TcErrors.reportTidyWanteds does not print the errors and does not fail if -fwarn-type-errors is on, so that we can continue compilation. The errors are turned into warnings in `reportUnsolved`. -\begin{code} +Note [Zonk after solving] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We zonk the result immediately after constraint solving, for two reasons: -solveWanteds :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind) --- Return the evidence binds in the BagEvBinds result -solveWanteds wanted = runTcS $ solve_wanteds wanted +a) because zonkWC generates evidence, and this is the moment when we + have a suitable evidence variable to hand. + +Note that *after* solving the constraints are typically small, so the +overhead is not great. -solveWantedsWithEvBinds :: EvBindsVar -> WantedConstraints -> TcM WantedConstraints --- Side-effect the EvBindsVar argument to add new bindings from solving -solveWantedsWithEvBinds ev_binds_var wanted - = runTcSWithEvBinds ev_binds_var $ solve_wanteds wanted +\begin{code} +solveWantedsTcMWithEvBinds :: EvBindsVar + -> WantedConstraints + -> (WantedConstraints -> TcS WantedConstraints) + -> TcM WantedConstraints +-- Returns a *zonked* result +-- We zonk when we finish primarily to un-flatten out any +-- flatten-skolems etc introduced by canonicalisation of +-- types involving type funuctions. Happily the result +-- is typically much smaller than the input, indeed it is +-- often empty. +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 } + -- See Note [Zonk after solving] + +solveWantedsTcM :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind) +-- Zonk the input constraints, and simplify them +-- Return the evidence binds in the BagEvBinds result +-- 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 + ; binds <- TcRnMonad.getTcEvBinds ev_binds_var + ; return (wanteds', binds) } +solve_wanteds_and_drop :: WantedConstraints -> TcS (WantedConstraints) +-- Since solve_wanteds returns the residual WantedConstraints, +-- it should alway be called within a runTcS or something similar, +solve_wanteds_and_drop wanted = do { wc <- solve_wanteds wanted + ; return (dropDerivedWC wc) } solve_wanteds :: 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) -- Try the flat bit, including insolubles. Solving insolubles a - -- second time round is a bit of a waste but the code is simple + -- second time round is a bit of a waste; but the code is simple -- and the program is wrong anyway, and we don't run the danger -- of adding Derived insolubles twice; see -- TcSMonad Note [Do not add duplicate derived insolubles] + ; traceTcS "solveFlats {" empty ; let all_flats = flats `unionBags` insols - - ; impls_from_flats <- solveInteractCts $ bagToList all_flats + ; 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) - ; is <- getTcSInerts - ; let insoluble_flats = getInertInsols is - unsolved_flats = getInertUnsolved is + ; (unsolved_flats, insoluble_flats) <- getInertUnsolved + -- 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 } + ; 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)) - ] - - ; let wc = WC { wc_flat = unsolved_flats - , wc_impl = unsolved_implics - , wc_insol = insoluble_flats } - - - ; traceTcS "solveWanteds finished with" $ - vcat [ text "wc (unflattened) =" <+> ppr wc ] - - ; unFlattenWC wc } - + , text "final wc =" <+> ppr wc ] + ; return wc } simpl_loop :: Int -> Bag Implication @@ -769,24 +743,13 @@ simpl_loop n implics | n > 10 = traceTcS "solveWanteds: loop!" empty >> return implics | otherwise - = do { (implic_eqs, unsolved_implics) <- solveNestedImplications implics - - ; let improve_eqs = implic_eqs - -- NB: improve_eqs used to contain defaulting equations HERE but - -- defaulting now happens only at simplifyTop and not deep inside - -- simpl_loop! See Note [Top-level Defaulting Plan] - - ; unsolved_flats <- getTcSInerts >>= (return . getInertUnsolved) - ; traceTcS "solveWanteds: simpl_loop end" $ - vcat [ text "improve_eqs =" <+> ppr improve_eqs - , text "unsolved_flats =" <+> ppr unsolved_flats - , text "unsolved_implics =" <+> ppr unsolved_implics ] - - - ; if isEmptyBag improve_eqs then return unsolved_implics - else do { impls_from_eqs <- solveInteractCts $ bagToList improve_eqs - ; simpl_loop (n+1) (unsolved_implics `unionBags` - impls_from_eqs)} } + = do { (floated_eqs, unsolved_implics) <- solveNestedImplications implics + ; if isEmptyBag floated_eqs + then return unsolved_implics + else + do { -- Put floated_eqs into the current inert set before looping + impls_from_eqs <- solveInteract floated_eqs + ; simpl_loop (n+1) (unsolved_implics `unionBags` impls_from_eqs)} } solveNestedImplications :: Bag Implication @@ -798,278 +761,153 @@ solveNestedImplications implics = return (emptyBag, emptyBag) | otherwise = do { inerts <- getTcSInerts - ; traceTcS "solveNestedImplications starting, inerts are:" $ ppr inerts - ; let (pushed_givens, thinner_inerts) = splitInertsForImplications inerts + ; let thinner_inerts = prepareInertsForImplications inerts + -- See Note [Preparing inert set for implications] - ; traceTcS "solveNestedImplications starting, more info:" $ + ; traceTcS "solveNestedImplications starting {" $ vcat [ text "original inerts = " <+> ppr inerts - , text "pushed_givens = " <+> ppr pushed_givens , text "thinner_inerts = " <+> ppr thinner_inerts ] - ; (implic_eqs, unsolved_implics) - <- doWithInert thinner_inerts $ - do { let tcs_untouchables - = foldr (unionVarSet . tyVarsOfCt) emptyVarSet pushed_givens - -- Typically pushed_givens is very small, consists - -- only of unsolved equalities, so no inefficiency - -- danger. - - - -- See Note [Preparing inert set for implications] - -- Push the unsolved wanteds inwards, but as givens - ; traceTcS "solveWanteds: preparing inerts for implications {" $ - vcat [ppr tcs_untouchables, ppr pushed_givens] - ; impls_from_givens <- solveInteractCts pushed_givens - - ; MASSERT (isEmptyBag impls_from_givens) - -- impls_from_givens must be empty, since we are reacting givens - -- with givens, and they can never generate extra implications - -- from decomposition of ForAll types. (Whereas wanteds can, see - -- TcCanonical, canEq ForAll-ForAll case) - - ; traceTcS "solveWanteds: } now doing nested implications {" empty - ; flatMapBagPairM (solveImplication tcs_untouchables) implics } + ; (floated_eqs, unsolved_implics) + <- flatMapBagPairM (solveImplication thinner_inerts) implics -- ... and we are back in the original TcS inerts -- Notice that the original includes the _insoluble_flats so it was safe to ignore -- them in the beginning of this function. - ; traceTcS "solveWanteds: done nested implications }" $ - vcat [ text "implic_eqs =" <+> ppr implic_eqs + ; traceTcS "solveNestedImplications end }" $ + vcat [ text "all floated_eqs =" <+> ppr floated_eqs , text "unsolved_implics =" <+> ppr unsolved_implics ] - ; return (implic_eqs, unsolved_implics) } + ; return (floated_eqs, unsolved_implics) } -solveImplication :: TcTyVarSet -- Untouchable TcS unification variables +solveImplication :: InertSet -> 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 tcs_untouchables +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_loc = loc }) - = shadowIPs givens $ -- See Note [Shadowing of Implicit Parameters] - nestImplicTcS ev_binds (untch, tcs_untouchables) $ - recoverTcS (return (emptyBag, emptyBag)) $ - -- Recover from nested failures. Even the top level is - -- just a bunch of implications, so failing at the first one is bad + , ic_info = info + , ic_env = env }) + = do { traceTcS "solveImplication {" (ppr imp) - -- Solve flat givens - ; impls_from_givens <- solveInteractGiven loc givens - ; MASSERT (isEmptyBag impls_from_givens) - - -- Simplify the wanteds - ; WC { wc_flat = unsolved_flats - , wc_impl = unsolved_implics - , wc_insol = insols } <- solve_wanteds wanteds - - ; let (res_flat_free, res_flat_bound) - = floatEqualities skols givens unsolved_flats - - ; let res_wanted = WC { wc_flat = res_flat_bound - , wc_impl = unsolved_implics - , wc_insol = insols } - - res_implic = unitImplication $ - imp { ic_wanted = res_wanted - , ic_insol = insolubleWC res_wanted } + -- Solve the nested constraints + -- NB: 'inerts' has empty inert_fsks + ; (new_fsks, residual_wanted) + <- nestImplicTcS ev_binds untch inerts $ + do { solveInteractGiven (mkGivenLoc info env) old_fsks givens + ; residual_wanted <- solve_wanteds wanteds + -- solve_wanteds, *not* solve_wanteds_and_drop, because + -- we want to retain derived equalities so we can float + -- them out in floatEqualities + ; more_fsks <- getFlattenSkols + ; return (more_fsks ++ old_fsks, residual_wanted) } + + ; (floated_eqs, final_wanted) + <- floatEqualities (skols ++ new_fsks) givens residual_wanted + + ; let res_implic | isEmptyWC final_wanted + = emptyBag + | otherwise + = unitBag (imp { ic_fsks = new_fsks + , ic_wanted = dropDerivedWC final_wanted + , ic_insol = insolubleWC final_wanted }) ; evbinds <- getTcEvBindsMap - ; traceTcS "solveImplication end }" $ vcat - [ text "res_flat_free =" <+> ppr res_flat_free - , text "implication evbinds = " <+> ppr (evBindMapBinds evbinds) - , text "res_implic =" <+> ppr res_implic ] - - ; return (res_flat_free, res_implic) } - -- and we are back to the original inerts + [ text "floated_eqs =" <+> ppr floated_eqs + , text "new_fsks =" <+> ppr new_fsks + , text "res_implic =" <+> ppr res_implic + , text "implication evbinds = " <+> ppr (evBindMapBinds evbinds) ] + ; return (floated_eqs, res_implic) } \end{code} \begin{code} -floatEqualities :: [TcTyVar] -> [EvVar] -> Cts -> (Cts, Cts) +floatEqualities :: [TcTyVar] -> [EvVar] -> WantedConstraints + -> TcS (Cts, WantedConstraints) -- Post: The returned FlavoredEvVar's are only Wanted or Derived -- and come from the input wanted ev vars or deriveds -floatEqualities skols can_given wantders - | hasEqualities can_given = (emptyBag, wantders) - -- Note [Float Equalities out of Implications] - | otherwise = partitionBag is_floatable wantders - where skol_set = mkVarSet skols - is_floatable :: Ct -> Bool - is_floatable ct - | ct_predty <- ctPred ct - , isEqPred ct_predty - = skol_set `disjointVarSet` tvs_under_fsks ct_predty - is_floatable _ct = False - - tvs_under_fsks :: Type -> TyVarSet - -- ^ NB: for type synonyms tvs_under_fsks does /not/ expand the synonym - tvs_under_fsks (TyVarTy tv) - | not (isTcTyVar tv) = unitVarSet tv - | FlatSkol ty <- tcTyVarDetails tv = tvs_under_fsks ty - | otherwise = unitVarSet tv - tvs_under_fsks (TyConApp _ tys) = unionVarSets (map tvs_under_fsks tys) - tvs_under_fsks (LitTy {}) = emptyVarSet - tvs_under_fsks (FunTy arg res) = tvs_under_fsks arg `unionVarSet` tvs_under_fsks res - tvs_under_fsks (AppTy fun arg) = tvs_under_fsks fun `unionVarSet` tvs_under_fsks arg - tvs_under_fsks (ForAllTy tv ty) -- The kind of a coercion binder - -- can mention type variables! - | isTyVar tv = inner_tvs `delVarSet` tv - | otherwise {- Coercion -} = -- ASSERT( not (tv `elemVarSet` inner_tvs) ) - inner_tvs `unionVarSet` tvs_under_fsks (tyVarKind tv) - where - inner_tvs = tvs_under_fsks ty - -shadowIPs :: [EvVar] -> TcS a -> TcS a -shadowIPs gs m - | null shadowed = m - | otherwise = do is <- getTcSInerts - doWithInert (purgeShadowed is) m +-- Also performs some unifications, adding to monadically-carried ty_binds +-- These will be used when processing floated_eqs later +floatEqualities skols can_given wanteds@(WC { wc_flat = flats }) + | hasEqualities can_given + = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] + | otherwise + = do { let (float_eqs, remaining_flats) = partitionBag is_floatable flats + ; promoteTyVars float_eqs + ; ty_binds <- getTcSTyBindsMap + ; traceTcS "floatEqualities" (vcat [ text "Floated eqs =" <+> ppr float_eqs + , text "Ty binds =" <+> ppr ty_binds]) + ; return (float_eqs, wanteds { wc_flat = remaining_flats }) } + where + skol_set = growSkols wanteds (mkVarSet skols) + + is_floatable :: Ct -> Bool + is_floatable ct + = isEqPred pred && skol_set `disjointVarSet` tyVarsOfType pred + where + pred = ctPred ct + +promoteTyVars :: Cts -> TcS () +-- When we float a constraint out of an implication we +-- must restore (MetaTvInv) in Note [Untouchable type variables] +-- in TcType +promoteTyVars cts + = do { untch <- TcSMonad.getUntouchables + ; mapM_ (promote_tv untch) (varSetElems (tyVarsOfCts cts)) } where - shadowed = mapMaybe isIP gs - - isIP g = do p <- evVarPred_maybe g - (x,_) <- isIPPred_maybe p - return x - - isShadowedCt ct = isShadowedEv (ctEvidence ct) - isShadowedEv ev = case isIPPred_maybe (ctEvPred ev) of - Just (x,_) -> x `elem` shadowed - _ -> False - - purgeShadowed is = is { inert_cans = purgeCans (inert_cans is) - , inert_solved = purgeSolved (inert_solved is) - } + promote_tv untch tv + | isFloatedTouchableMetaTyVar untch tv + = do { cloned_tv <- TcSMonad.cloneMetaTyVar tv + ; let rhs_tv = setMetaTyVarUntouchables cloned_tv untch + ; setWantedTyBind tv (mkTyVarTy rhs_tv) } + | otherwise + = return () + +growSkols :: WantedConstraints -> VarSet -> VarSet +-- Find all the type variables that might possibly be unified +-- with a type that mentions a skolem. This test is very conservative. +-- I don't *think* we need look inside the implications, because any +-- relevant unification variables in there are untouchable. +growSkols (WC { wc_flat = flats }) skols + = growThetaTyVars theta skols + where + theta = foldrBag ((:) . ctPred) [] flats - purgeDicts = snd . partitionCCanMap isShadowedCt - purgeCans ics = ics { inert_dicts = purgeDicts (inert_dicts ics) } - purgeSolved = filterSolved (not . isShadowedEv) +approximateWC :: WantedConstraints -> Cts +-- Postcondition: Wanted or Derived Cts +approximateWC wc = float_wc emptyVarSet wc + where + float_wc :: TcTyVarSet -> WantedConstraints -> Cts + float_wc skols (WC { wc_flat = flat, wc_impl = implic }) = floats1 `unionBags` floats2 + where floats1 = do_bag (float_flat skols) flat + floats2 = do_bag (float_implic skols) implic + + float_implic :: TcTyVarSet -> Implication -> Cts + float_implic skols imp + = float_wc skols' (ic_wanted imp) + where + skols' = skols `extendVarSetList` ic_skols imp `extendVarSetList` ic_fsks imp + + float_flat :: TcTyVarSet -> Ct -> Cts + float_flat skols ct + | tyVarsOfCt ct `disjointVarSet` skols + = singleCt ct + | otherwise = emptyCts + + do_bag :: (a -> Bag c) -> Bag a -> Bag c + do_bag f = foldrBag (unionBags.f) emptyBag \end{code} -Note [Preparing inert set for implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before solving the nested implications, we convert any unsolved flat wanteds -to givens, and add them to the inert set. Reasons: - - a) In checking mode, suppresses unnecessary errors. We already have - on unsolved-wanted error; adding it to the givens prevents any - consequential errors from showing up - - b) More importantly, in inference mode, we are going to quantify over this - constraint, and we *don't* want to quantify over any constraints that - are deducible from it. - - c) Flattened type-family equalities must be exposed to the nested - constraints. Consider - F b ~ alpha, (forall c. F b ~ alpha) - Obviously this is soluble with [alpha := F b]. But the - unification is only done by solveCTyFunEqs, right at the end of - solveWanteds, and if we aren't careful we'll end up with an - unsolved goal inside the implication. We need to "push" the - as-yes-unsolved (F b ~ alpha) inwards, as a *given*, so that it - can be used to solve the inner (F b - ~ alpha). See Trac #4935. - - d) There are other cases where interactions between wanteds that can 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 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).) - -The unsolved wanteds are *canonical* but they may not be *inert*, -because when made into a given they might interact with other givens. -Hence the call to solveInteract. Example: - - Original inert set = (d :_g D a) /\ (co :_w a ~ [beta]) - -We were not able to solve (a ~w [beta]) but we can't just assume it as -given because the resulting set is not inert. Hence we have to do a -'solveInteract' step first. - -Finally, note that we convert them to [Given] and NOT [Given/Solved]. -The reason is that Given/Solved are weaker than Givens and may be discarded. -As an example consider the inference case, where we may have, the following -original constraints: - [Wanted] F Int ~ Int - (F Int ~ a => F Int ~ a) -If we convert F Int ~ Int to [Given/Solved] instead of Given, then the next -given (F Int ~ a) is going to cause the Given/Solved to be ignored, casting -the (F Int ~ a) insoluble. Hence we should really convert the residual -wanteds to plain old Given. - -We need only push in unsolved equalities both in checking mode and inference mode: - - (1) In checking mode 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. But even in -checking mode, we must still push type family equations. Consider: - - 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 - -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 (NB: not -merely Given/Solved because it has to interact with the top-level instance -environment) and push it inside the implications. Now, when we come out again at -the end, having solved the implications solveCTyFunEqs will solve this equality. - - (2) In inference mode, we recheck the final constraint in checking mode and -hence we will be able to solve inner implications from top-level quantified -constraints nonetheless. - - -Note [Extra TcsTv untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Whenever we are solving a bunch of flat constraints, they may contain -the following sorts of 'touchable' unification variables: - - (i) Born-touchables in that scope - - (ii) Simplifier-generated unification variables, such as unification - flatten variables - - (iii) Touchables that have been floated out from some nested - implications, see Note [Float Equalities out of Implications]. - -Now, once we are done with solving these flats and have to move inwards to -the nested implications (perhaps for a second time), we must consider all the -extra variables (categories (ii) and (iii) above) as untouchables for the -implication. Otherwise we have the danger or double unifications, as well -as the danger of not ``seing'' some unification. Example (from Trac #4494): - - (F Int ~ uf) /\ [untch=beta](forall a. C a => F Int ~ beta) - -In this example, beta is touchable inside the implication. The -first solveInteract step leaves 'uf' ununified. Then we move inside -the implication where a new constraint - uf ~ beta -emerges. We may spontaneously solve it to get uf := beta, so 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 -uf will get unified *once more* to (F Int). - -The solution is to record the unification variables of the flats, -and make them untouchables for the nested implication. In the -example above uf would become untouchable, so beta would be forced -to be unified as beta := uf. - Note [Float Equalities out of Implications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For ordinary pattern matches (including existentials) we float @@ -1115,16 +953,21 @@ 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). -Notice that, due to Note [Extra TcSTv Untouchables], the free unification variables -of an equality that is floated out of an implication become effectively untouchables -for the leftover implication. This is absolutely necessary. Consider the following -example. We start with two implications and a class with a functional dependency. +Note [Promoting unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we float an equality out of an implication we must "promote" free +unification variables of the equality, in order to maintain Invariant +(MetaTvInv) from Note [Untouchable type variables] in TcType. for the +leftover implication. -class C x y | x -> y -instance C [a] [a] - -(I1) [untch=beta]forall b. 0 => F Int ~ [beta] -(I2) [untch=beta]forall b. 0 => F Int ~ [[alpha]] /\ C beta [b] +This is absolutely necessary. Consider the following example. We start +with two implications and a class with a functional dependency. + + class C x y | x -> y + instance C [a] [a] + + (I1) [untch=beta]forall b. 0 => F Int ~ [beta] + (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. They may react to yield that (beta := [alpha]) which can then be pushed inwards @@ -1132,143 +975,27 @@ the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean tha (alpha := a). In the end we will have the skolem 'b' escaping in the untouchable beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: -class C x y | x -> y where - op :: x -> y -> () - -instance C [a] [a] - -type family F a :: * - -h :: F Int -> () -h = undefined - -data TEx where - TEx :: a -> TEx - - -f (x::beta) = - 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) - -Note [Shadowing of Implicit Parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example: + class C x y | x -> y where + op :: x -> y -> () -f :: (?x :: Char) => Char -f = let ?x = 'a' in ?x + instance C [a] [a] -The "let ?x = ..." generates an implication constraint of the form: + type family F a :: * -?x :: Char => ?x :: Char + h :: F Int -> () + h = undefined + data TEx where + TEx :: a -> TEx -Furthermore, the signature for `f` also generates an implication -constraint, so we end up with the following nested implication: -?x :: Char => (?x :: Char => ?x :: Char) + f (x::beta) = + 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) -Note that the wanted (?x :: Char) constraint may be solved in -two incompatible ways: either by using the parameter from the -signature, or by using the local definition. Our intention is -that the local definition should "shadow" the parameter of the -signature, and we implement this as follows: when we nest implications, -we remove any implicit parameters in the outer implication, that -have the same name as givens of the inner implication. -Here is another variation of the example: - -f :: (?x :: Int) => Char -f = let ?x = 'x' in ?x - -This program should also be accepted: the two constraints `?x :: Int` -and `?x :: Char` never exist in the same context, so they don't get to -interact to cause failure. -\begin{code} - - - -unFlattenWC :: WantedConstraints -> TcS WantedConstraints -unFlattenWC wc - = do { (subst, remaining_unsolved_flats) <- solveCTyFunEqs (wc_flat wc) - -- See Note [Solving Family Equations] - -- NB: remaining_flats has already had subst applied - ; return $ - WC { wc_flat = mapBag (substCt subst) remaining_unsolved_flats - , wc_impl = mapBag (substImplication subst) (wc_impl wc) - , wc_insol = mapBag (substCt subst) (wc_insol wc) } - } - where - solveCTyFunEqs :: Cts -> TcS (TvSubst, Cts) - -- Default equalities (F xi ~ alpha) by setting (alpha := F xi), whenever possible - -- See Note [Solving Family Equations] - -- Returns: a bunch of unsolved constraints from the original Cts and implications - -- where the newly generated equalities (alpha := F xi) have been substituted through. - solveCTyFunEqs cts - = do { untch <- getUntouchables - ; let (unsolved_can_cts, (ni_subst, cv_binds)) - = getSolvableCTyFunEqs untch cts - ; traceTcS "defaultCTyFunEqs" (vcat [text "Trying to default family equations:" - , ppr ni_subst, ppr cv_binds - ]) - ; mapM_ solve_one cv_binds - - ; return (niFixTvSubst ni_subst, unsolved_can_cts) } - where - solve_one (Wanted { ctev_evar = cv }, tv, ty) - = setWantedTyBind tv ty >> setEvBind cv (EvCoercion (mkTcReflCo ty)) - solve_one (Derived {}, tv, ty) - = setWantedTyBind tv ty - solve_one arg - = pprPanic "solveCTyFunEqs: can't solve a /given/ family equation!" $ ppr arg - ------------- -type FunEqBinds = (TvSubstEnv, [(CtEvidence, TcTyVar, TcType)]) - -- The TvSubstEnv is not idempotent, but is loop-free - -- See Note [Non-idempotent substitution] in Unify -emptyFunEqBinds :: FunEqBinds -emptyFunEqBinds = (emptyVarEnv, []) - -extendFunEqBinds :: FunEqBinds -> CtEvidence -> TcTyVar -> TcType -> FunEqBinds -extendFunEqBinds (tv_subst, cv_binds) fl tv ty - = (extendVarEnv tv_subst tv ty, (fl, tv, ty):cv_binds) - ------------- -getSolvableCTyFunEqs :: TcsUntouchables - -> Cts -- Precondition: all Wanteds or Derived! - -> (Cts, FunEqBinds) -- Postcondition: returns the unsolvables -getSolvableCTyFunEqs untch cts - = Bag.foldlBag dflt_funeq (emptyCts, emptyFunEqBinds) cts - where - dflt_funeq :: (Cts, FunEqBinds) -> Ct - -> (Cts, FunEqBinds) - dflt_funeq (cts_in, feb@(tv_subst, _)) - (CFunEqCan { cc_ev = fl - , cc_fun = tc - , cc_tyargs = xis - , cc_rhs = xi }) - | Just tv <- tcGetTyVar_maybe xi -- RHS is a type variable - - , isTouchableMetaTyVar_InRange untch tv - -- And it's a *touchable* unification variable - - , typeKind xi `tcIsSubKind` tyVarKind tv - -- Must do a small kind check since TcCanonical invariants - -- on family equations only impose compatibility, not subkinding - - , not (tv `elemVarEnv` tv_subst) - -- Check not in extra_binds - -- See Note [Solving Family Equations], Point 1 - - , not (tv `elemVarSet` niSubstTvSet tv_subst (tyVarsOfTypes xis)) - -- Occurs check: see Note [Solving Family Equations], Point 2 - = ASSERT ( not (isGiven fl) ) - (cts_in, extendFunEqBinds feb fl tv (mkTyConApp tc xis)) - - dflt_funeq (cts_in, fun_eq_binds) ct - = (cts_in `extendCts` ct, fun_eq_binds) -\end{code} Note [Solving Family Equations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1288,7 +1015,10 @@ When is it ok to do so? set [beta := F xis] only if beta is not among the free variables of xis. 3) Notice that 'beta' can't be bound in ty binds already because we rewrite RHS - of type family equations. See Inert Set invariants in TcInteract. + of type family equations. See Inert Set invariants in TcInteract. + +This solving is now happening during zonking, see Note [Unflattening while zonking] +in TcMType. ********************************************************************************* @@ -1297,13 +1027,14 @@ When is it ok to do so? * * ********************************************************************************* \begin{code} -applyDefaultingRules :: Cts -- Wanteds or Deriveds - -> TcS Cts -- Derived equalities +applyDefaultingRules :: Cts -> TcS Bool + -- True <=> I did some defaulting, reflected in ty_binds + -- Return some extra derived equalities, which express the -- type-class default choice. applyDefaultingRules wanteds | isEmptyBag wanteds - = return emptyBag + = return False | otherwise = do { traceTcS "applyDefaultingRules { " $ text "wanteds =" <+> ppr wanteds @@ -1312,17 +1043,15 @@ applyDefaultingRules wanteds ; let groups = findDefaultableGroups info wanteds ; traceTcS "findDefaultableGroups" $ vcat [ text "groups=" <+> ppr groups , text "info=" <+> ppr info ] - ; deflt_cts <- mapM (disambigGroup default_tys) groups + ; something_happeneds <- mapM (disambigGroup default_tys) groups - ; traceTcS "applyDefaultingRules }" $ - vcat [ text "Type defaults =" <+> ppr deflt_cts] + ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) - ; return (unionManyBags deflt_cts) } + ; return (or something_happeneds) } \end{code} Note [tryTcS in defaulting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - defaultTyVar and disambigGroup create new evidence variables for default equations, and hence update the EvVar cache. However, after applyDefaultingRules we will try to solve these default equations @@ -1345,48 +1074,29 @@ in the cache! \begin{code} ------------------- -touchablesOfWC :: WantedConstraints -> TcTyVarSet --- See Note [Extra Tcs Untouchables] to see why we carry a TcsUntouchables --- instead of just using the Untouchable range have in our hands. -touchablesOfWC = go (NoUntouchables, emptyVarSet) - where go :: TcsUntouchables -> WantedConstraints -> TcTyVarSet - go untch (WC { wc_flat = flats, wc_impl = impls }) - = filterVarSet is_touchable flat_tvs `unionVarSet` - foldrBag (unionVarSet . (go_impl $ untch_for_impls untch)) emptyVarSet impls - where is_touchable = isTouchableMetaTyVar_InRange untch - flat_tvs = tyVarsOfCts flats - untch_for_impls (r,uset) = (r, uset `unionVarSet` flat_tvs) - go_impl (_rng,set) implic = go (ic_untch implic,set) (ic_wanted implic) - -applyTyVarDefaulting :: WantedConstraints -> TcM Cts -applyTyVarDefaulting wc = runTcS do_dflt >>= (return . fst) - where do_dflt = do { tv_cts <- mapM defaultTyVar $ - varSetElems (touchablesOfWC wc) - ; return (unionManyBags tv_cts) } - -defaultTyVar :: TcTyVar -> TcS Cts --- Precondition: a touchable meta-variable +applyTyVarDefaulting :: WantedConstraints -> TcS () +applyTyVarDefaulting wc + = do { let tvs = filter isMetaTyVar (varSetElems (tyVarsOfWC wc)) + -- tyVarsOfWC: post-simplification the WC should reflect + -- all unifications that have happened + -- filter isMetaTyVar: we might have runtime-skolems in GHCi, + -- and we definitely don't want to try to assign to those! + + ; traceTcS "applyTyVarDefaulting {" (ppr tvs) + ; mapM_ defaultTyVar tvs + ; traceTcS "applyTyVarDefaulting end }" empty } + +defaultTyVar :: TcTyVar -> TcS () defaultTyVar the_tv | not (k `eqKind` default_k) - -- Why tryTcS? See Note [tryTcS in defaulting] - = tryTcS $ - do { let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk - ; ty_k <- instFlexiTcSHelperTcS (tyVarName the_tv) default_k - ; md <- newDerived loc (mkTcEqPred (mkTyVarTy the_tv) ty_k) - -- Why not directly newDerived loc (mkTcEqPred k default_k)? + = do { tv' <- TcSMonad.cloneMetaTyVar the_tv + ; let rhs_ty = mkTyVarTy (setTyVarKind tv' default_k) + ; setWantedTyBind the_tv rhs_ty } + -- Why not directly derived_pred = mkTcEqPred k default_k? -- See Note [DefaultTyVar] - ; let cts - | Just der_ev <- md = [mkNonCanonical der_ev] - | otherwise = [] - - ; implics_from_defaulting <- solveInteractCts cts - ; MASSERT (isEmptyBag implics_from_defaulting) - - ; unsolved <- getTcSInerts >>= (return . getInertUnsolved) - ; if isEmptyBag (keepWanted unsolved) then return (listToBag cts) - else return emptyBag } - | otherwise = return emptyBag -- The common case + -- We keep the same Untouchables on tv' + + | otherwise = return () -- The common case where k = tyVarKind the_tv default_k = defaultKind k @@ -1421,37 +1131,37 @@ default is default_k we do not simply generate [D] (k ~ default_k) because: right kind. \begin{code} - - ----------------- findDefaultableGroups :: ( [Type] , (Bool,Bool) ) -- (Overloaded strings, extended default rules) -> Cts -- Unsolved (wanted or derived) - -> [[(Ct,TcTyVar)]] + -> [[(Ct,Class,TcTyVar)]] findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds | null default_tys = [] | otherwise = filter is_defaultable_group (equivClasses cmp_tv unaries) where - unaries :: [(Ct, TcTyVar)] -- (C tv) constraints + unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints non_unaries :: [Ct] -- and *other* constraints (unaries, non_unaries) = partitionWith find_unary (bagToList wanteds) -- Finds unary type-class constraints - find_unary cc@(CDictCan { cc_tyargs = [ty] }) - | Just tv <- tcGetTyVar_maybe ty - = Left (cc, tv) + find_unary cc + | Just (cls,[ty]) <- getClassPredTys_maybe (ctPred cc) + , Just tv <- tcGetTyVar_maybe ty + , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and + -- we definitely don't want to try to assign to those! + = Left (cc, cls, tv) find_unary cc = Right cc -- Non unary or non dictionary bad_tvs :: TcTyVarSet -- TyVars mentioned by non-unaries bad_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet non_unaries - cmp_tv (_,tv1) (_,tv2) = tv1 `compare` tv2 + cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 - is_defaultable_group ds@((_,tv):_) + is_defaultable_group ds@((_,_,tv):_) = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] b2 = not (tv `elemVarSet` bad_tvs) - b4 = defaultable_classes [cc_class cc | (cc,_) <- ds] + b4 = defaultable_classes [cls | (_,cls,_) <- ds] in (b1 && b2 && b4) is_defaultable_group [] = panic "defaultable_group" @@ -1472,54 +1182,42 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds -- Similarly is_std_class ------------------------------ -disambigGroup :: [Type] -- The default types - -> [(Ct, TcTyVar)] -- All classes of the form (C a) - -- sharing same type variable - -> TcS Cts +disambigGroup :: [Type] -- The default types + -> [(Ct, Class, TcTyVar)] -- All classes of the form (C a) + -- sharing same type variable + -> TcS Bool -- True <=> something happened, reflected in ty_binds disambigGroup [] _grp - = return emptyBag + = return False disambigGroup (default_ty:default_tys) group = do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty) ; success <- tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting] - do { derived_eq <- tryTcS $ - -- I need a new tryTcS because we will call solveInteractCts below! - do { md <- newDerived (ctev_wloc the_fl) - (mkTcEqPred (mkTyVarTy the_tv) default_ty) - -- ctev_wloc because constraint is not Given! - ; case md of - Nothing -> return [] - Just ctev -> return [ mkNonCanonical ctev ] } - + do { setWantedTyBind the_tv default_ty ; traceTcS "disambigGroup (solving) {" $ text "trying to solve constraints along with default equations ..." - ; implics_from_defaulting <- - solveInteractCts (derived_eq ++ wanteds) + ; 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. - ; unsolved <- getTcSInerts >>= (return . getInertUnsolved) + ; all_solved <- checkAllSolved ; traceTcS "disambigGroup (solving) }" $ - text "disambigGroup unsolved =" <+> ppr (keepWanted unsolved) - ; if isEmptyBag (keepWanted unsolved) then -- Don't care about Derived's - return (Just $ listToBag derived_eq) - else - return Nothing - } - ; case success of - Just cts -> -- Success: record the type variable binding, and return - do { wrapWarnTcS $ warnDefaulting wanteds default_ty - ; traceTcS "disambigGroup succeeded" (ppr default_ty) - ; return cts } - Nothing -> -- Failure: try with the next type - do { traceTcS "disambigGroup failed, will try other default types" - (ppr default_ty) - ; disambigGroup default_tys group } } + text "disambigGroup solved =" <+> ppr all_solved + ; return all_solved } + ; if success then + -- Success: record the type variable binding, and return + do { setWantedTyBind the_tv default_ty + ; wrapWarnTcS $ warnDefaulting wanteds default_ty + ; traceTcS "disambigGroup succeeded" (ppr default_ty) + ; return True } + else + -- Failure: try with the next type + do { traceTcS "disambigGroup failed, will try other default types" + (ppr default_ty) + ; disambigGroup default_tys group } } where - ((the_ct,the_tv):_) = group - the_fl = cc_ev the_ct - wanteds = map fst group + ((_,_,the_tv):_) = group + wanteds = listToBag (map fstOf3 group) \end{code} Note [Avoiding spurious errors] @@ -1551,9 +1249,7 @@ newFlatWanteds orig theta where inst_to_wanted loc pty = do { v <- TcMType.newWantedEvVar pty - ; return $ - CNonCanonical { cc_ev = Wanted { ctev_evar = v - , ctev_wloc = loc - , ctev_pred = pty } - , cc_depth = 0 } } + ; return $ mkNonCanonical loc $ + CtWanted { ctev_evar = v + , ctev_pred = pty } } \end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 334c3a5c36..c5f0af3ff1 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -348,7 +348,7 @@ tcBracket brack res_ty -- We will type check this bracket again at its usage site. -- -- We build a single implication constraint with a BracketSkol; - -- that in turn tells simplifyCheck to report only definite + -- that in turn tells simplifyTop to report only definite -- errors ; (_,lie) <- captureConstraints $ newImplication BracketSkol [] [] $ @@ -497,6 +497,12 @@ tcTopSpliceExpr :: TcM (LHsExpr Id) -> TcM (LHsExpr Id) tcTopSpliceExpr tc_action = checkNoErrs $ -- checkNoErrs: must not try to run the thing -- if the type checker fails! + unsetDOptM Opt_DeferTypeErrors $ + -- Don't defer type errors. Not only are we + -- going to run this code, but we do an unsafe + -- coerce, so we get a seg-fault if, say we + -- splice a type into a place where an expression + -- is expected (Trac #7276) setStage Splice $ do { -- Typecheck the expression (expr', lie) <- captureConstraints tc_action @@ -872,7 +878,7 @@ runMeta show_code run_and_convert expr exn_msg <- liftIO $ Panic.safeShowException exn let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", nest 2 (text exn_msg), - if show_code then nest 2 (text "Code:" <+> ppr expr) else empty] + if show_code then text "Code:" <+> ppr expr else empty] failWithTc msg \end{code} @@ -1227,9 +1233,8 @@ reifyTyCon tc (TH.FamilyD flavour (reifyName tc) tvs' kind') instances) } - | isSynTyCon tc - = do { let (tvs, rhs) = synTyConDefn tc - ; rhs' <- reifyType rhs + | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym + = do { rhs' <- reifyType rhs ; tvs' <- reifyTyVars tvs ; return (TH.TyConI (TH.TySynD (reifyName tc) tvs' rhs')) @@ -1376,10 +1381,10 @@ reify_kc_app :: TyCon -> [TypeRep.Kind] -> TcM TH.Kind reify_kc_app kc kis = fmap (foldl TH.AppT r_kc) (mapM reifyKind kis) where - r_kc | isPromotedTyCon kc && - isTupleTyCon (promotedTyCon kc) = TH.TupleT (tyConArity kc) - | kc `hasKey` listTyConKey = TH.ListT - | otherwise = TH.ConT (reifyName kc) + r_kc | Just tc <- isPromotedTyCon_maybe kc + , isTupleTyCon tc = TH.TupleT (tyConArity kc) + | kc `hasKey` listTyConKey = TH.ListT + | otherwise = TH.ConT (reifyName kc) reifyCxt :: [PredType] -> TcM [TH.Pred] reifyCxt = mapM reifyPred @@ -1410,8 +1415,8 @@ reify_tc_app tc tys where arity = tyConArity tc r_tc | isTupleTyCon tc = if isPromotedDataCon tc - then TH.PromotedTupleT arity - else TH.TupleT arity + then TH.PromotedTupleT arity + else TH.TupleT arity | tc `hasKey` listTyConKey = TH.ListT | tc `hasKey` nilDataConKey = TH.PromotedNilT | tc `hasKey` consDataConKey = TH.PromotedConsT diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index e25ddc7580..4d5e7d5937 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -28,7 +28,6 @@ module TcTyClsDecls ( import HsSyn import HscTypes import BuildTyCl -import TcUnify import TcRnMonad import TcEnv import TcHsSyn @@ -533,7 +532,8 @@ tcTyClDecl1 parent _calc_isrec = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { traceTc "type family:" (ppr tc_name) ; checkFamFlag tc_name - ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent + ; let syn_rhs = SynFamilyTyCon { synf_open = True, synf_injective = False } + ; tycon <- buildSynTyCon tc_name tvs' syn_rhs kind parent ; return [ATyCon tycon] } -- "data family" declaration @@ -658,7 +658,7 @@ tcTyDefn calc_isrec tc_name tvs kind Nothing -> return () Just hs_k -> do { checkTc (kind_signatures) (badSigTyDecl tc_name) ; tc_kind <- tcLHsKind hs_k - ; _ <- unifyKind kind tc_kind + ; checkKind kind tc_kind ; return () } ; dataDeclChecks tc_name new_or_data stupid_theta cons @@ -770,12 +770,12 @@ kcTyDefn (TySynonym { td_synRhs = rhs_ty }) res_k ------------------ kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM () kcResultKind Nothing res_k - = discardResult (unifyKind res_k liftedTypeKind) + = checkKind res_k liftedTypeKind -- type family F a -- defaults to type family F a :: * -kcResultKind (Just k ) res_k +kcResultKind (Just k) res_k = do { k' <- tcLHsKind k - ; discardResult (unifyKind k' res_k) } + ; checkKind k' res_k } ------------------------- -- Kind check type patterns and kind annotate the embedded type variables. @@ -1306,8 +1306,8 @@ checkValidTyCon tc | Just cl <- tyConClass_maybe tc = checkValidClass cl - | isSynTyCon tc - = case synTyConRhs tc of + | Just syn_rhs <- synTyConRhs_maybe tc + = case syn_rhs of SynFamilyTyCon {} -> return () SynonymTyCon ty -> checkValidType syn_ctxt ty diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 00fce7267e..3df8209eed 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -195,17 +195,6 @@ calcClassCycles cls expandTheta _ _ [] = id expandTheta seen path (pred:theta) = expandType seen path pred . expandTheta seen path theta - {- - expandTree seen path (ClassPred cls tys) - | cls `elemUniqSet` seen = - | otherwise = expandTheta (addOneToUniqSet cls seen) (classTyCon cls:path) - (substTysWith (classTyVars cls) tys (classSCTheta cls)) - expandTree seen path (TuplePred ts) = flip (foldr (expandTree seen path)) ts - expandTree _ _ (EqPred _ _) = id - expandTree _ _ (IPPred _ _) = id - expandTree seen path (IrredPred pred) = expandType seen path pred - -} - expandType seen path (TyConApp tc tys) -- Expand unsaturated classes to their superclass theta if they are yet unseen. -- If they have already been seen then we have detected an error! @@ -222,9 +211,8 @@ calcClassCycles cls -- For synonyms, try to expand them: some arguments might be -- phantoms, after all. We can expand with impunity because at -- this point the type synonym cycle check has already happened. - | isSynTyCon tc - , SynonymTyCon rhs <- synTyConRhs tc - , let (env, remainder) = papp (tyConTyVars tc) tys + | Just (tvs, rhs) <- synTyConDefn_maybe tc + , let (env, remainder) = papp tvs tys rest_tys = either (const []) id remainder = expandType seen (tc:path) (substTy (mkTopTvSubst env) rhs) . flip (foldr (expandType seen path)) rest_tys diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index c656f0641f..b8594afcec 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -28,6 +28,9 @@ module TcType ( TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcKind, TcCoVar, + -- Untouchables + Untouchables(..), noUntouchables, pushUntouchables, isTouchable, + -------------------------------- -- MetaDetails UserTypeCtxt(..), pprUserTypeCtxt, @@ -35,9 +38,11 @@ module TcType ( MetaDetails(Flexi, Indirect), MetaInfo(..), isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, isSigTyVar, isOverlappableTyVar, isTyConableTyVar, - isAmbiguousTyVar, metaTvRef, + isAmbiguousTyVar, metaTvRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, - isTypeVar, isKindVar, + isTypeVar, isKindVar, + metaTyVarUntouchables, setMetaTyVarUntouchables, + isTouchableMetaTyVar, isFloatedTouchableMetaTyVar, -------------------------------- -- Builders @@ -118,7 +123,6 @@ module TcType ( openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, tcIsSubKind, splitKindFunTys, defaultKind, - mkMetaKindVar, -------------------------------- -- Rexported from Type @@ -304,13 +308,16 @@ data TcTyVarDetails -- to represent a flattening skolem variable alpha -- identified with type ty. - | MetaTv MetaInfo (IORef MetaDetails) + | MetaTv { mtv_info :: MetaInfo + , mtv_ref :: IORef MetaDetails + , mtv_untch :: Untouchables } -- See Note [Untouchable type variables] vanillaSkolemTv, superSkolemTv :: TcTyVarDetails -- See Note [Binding when looking up instances] in InstEnv vanillaSkolemTv = SkolemTv False -- Might be instantiated superSkolemTv = SkolemTv True -- Treat this as a completely distinct type +----------------------------- data MetaDetails = Flexi -- Flexi type variables unify to become Indirects | Indirect TcType @@ -331,11 +338,6 @@ data MetaInfo -- The MetaDetails, if filled in, will -- always be another SigTv or a SkolemTv - | TcsTv -- A MetaTv allocated by the constraint solver - -- Its particular property is that it is always "touchable" - -- Nevertheless, the constraint solver has to try to guess - -- what type to instantiate it to - ------------------------------------- -- UserTypeCtxt describes the origin of the polymorphic type -- in the places where we need to an expression has that type @@ -383,21 +385,92 @@ data UserTypeCtxt -- -- With gla-exts that's right, but for H98 we should complain. ---------------------------------- --- Kind variables: + +%************************************************************************ +%* * + Untoucable type variables +%* * +%************************************************************************ + +Note [Untouchable type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Each unification variable (MetaTv) + and each Implication + has a level number (of type Untouchables) + +* INVARIANTS. In a tree of Implications, + + (ImplicInv) The level number of an Implication is + STRICTLY GREATER THAN that of its parent + + (MetaTvInv) The level number of a unification variable is + LESS THAN OR EQUAL TO that of its parent + implication + +* A unification variable is *touchable* if its level number + is EQUAL TO that of its immediate parent implication. + +Note [Skolem escape prevention] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only unify touchable unification variables. Because of +(MetaTvInv), there can be no occurrences of he variable further out, +so the unification can't cause the kolems to escape. Example: + data T = forall a. MkT a (a->Int) + f x (MkT v f) = length [v,x] +We decide (x::alpha), and generate an implication like + [1]forall a. (a ~ alpha[0]) +But we must not unify alpha:=a, because the skolem would escape. + +For the cases where we DO want to unify, we rely on floating the +equality. Example (with same T) + g x (MkT v f) = x && True +We decide (x::alpha), and generate an implication like + [1]forall a. (Bool ~ alpha[0]) +We do NOT unify directly, bur rather float out (if the constraint +does not memtion 'a') to get + (Bool ~ alpha[0]) /\ [1]forall a.() +and NOW we can unify alpha. + +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 +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 +uf will get unified *once more* to (F Int). + \begin{code} -mkKindName :: Unique -> Name -mkKindName unique = mkSystemName unique kind_var_occ +newtype Untouchables = Untouchables Int + +noUntouchables :: Untouchables +noUntouchables = Untouchables 0 -- 0 = 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 -mkMetaKindVar :: Unique -> IORef MetaDetails -> MetaKindVar -mkMetaKindVar u r - = mkTcTyVar (mkKindName u) superKind (MetaTv TauTv r) +isTouchable :: Untouchables -> Untouchables -> Bool +isTouchable (Untouchables ctxt_untch) (Untouchables tv_untch) + = ctxt_untch == tv_untch -- NB: invariant ctxt_untch >= tv_untch + -- So <= would be equivalent -kind_var_occ :: OccName -- Just one for all MetaKindVars - -- They may be jiggled by tidying -kind_var_occ = mkOccName tvName "k" +checkTouchableInvariant :: Untouchables -> Untouchables -> Bool +-- Checks (MetaTvInv) from Note [Untouchable type variables] +checkTouchableInvariant (Untouchables ctxt_untch) (Untouchables tv_untch) + = ctxt_untch >= tv_untch + +instance Outputable Untouchables where + ppr (Untouchables us) = ppr us \end{code} + %************************************************************************ %* * Pretty-printing @@ -411,9 +484,12 @@ pprTcTyVarDetails (SkolemTv True) = ptext (sLit "ssk") pprTcTyVarDetails (SkolemTv False) = ptext (sLit "sk") pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") -pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") -pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs") -pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig") +pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_untch = untch }) + = pp_info <> brackets (ppr untch) + where + pp_info = case info of + TauTv -> ptext (sLit "tau") + SigTv -> ptext (sLit "sig") pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n) @@ -511,20 +587,11 @@ tidyOpenTyVar env@(_, subst) tyvar Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder --------------- -tidyTyVarOcc :: TidyEnv -> TyVar -> Type -tidyTyVarOcc env@(_, subst) tv +tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar +tidyTyVarOcc (_, subst) tv = case lookupVarEnv subst tv of - Nothing -> expand tv - Just tv' -> expand tv' - where - -- Expand FlatSkols, the skolems introduced by flattening process - -- We don't want to show them in type error messages - expand tv | isTcTyVar tv - , FlatSkol ty <- tcTyVarDetails tv - = WARN( True, text "I DON'T THINK THIS SHOULD EVER HAPPEN" <+> ppr tv <+> ppr ty ) - tidyType env ty - | otherwise - = TyVarTy tv + Nothing -> tv + Just tv' -> tv' --------------- tidyTypes :: TidyEnv -> [Type] -> [Type] @@ -533,7 +600,7 @@ tidyTypes env tys = map (tidyType env) tys --------------- tidyType :: TidyEnv -> Type -> Type tidyType _ (LitTy n) = LitTy n -tidyType env (TyVarTy tv) = tidyTyVarOcc env tv +tidyType env (TyVarTy tv) = TyVarTy (tidyTyVarOcc env tv) tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys in args `seqList` TyConApp tycon args tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) @@ -595,6 +662,7 @@ tidyCo env@(_, subst) co go (SymCo co) = SymCo $! go co go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 go (NthCo d co) = NthCo d $! go co + go (LRCo lr co) = LRCo lr $! go co go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty tidyCos :: TidyEnv -> [Coercion] -> [Coercion] @@ -683,8 +751,24 @@ exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys %************************************************************************ \begin{code} -isImmutableTyVar :: TyVar -> Bool +isTouchableMetaTyVar :: Untouchables -> TcTyVar -> Bool +isTouchableMetaTyVar ctxt_untch tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_untch = tv_untch } + -> ASSERT2( checkTouchableInvariant ctxt_untch tv_untch, + ppr tv $$ ppr tv_untch $$ ppr ctxt_untch ) + isTouchable ctxt_untch tv_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 + _ -> False +isImmutableTyVar :: TyVar -> Bool isImmutableTyVar tv | isTcTyVar tv = isSkolemTyVar tv | otherwise = True @@ -698,8 +782,8 @@ isTyConableTyVar tv -- not a SigTv = ASSERT( isTcTyVar tv) case tcTyVarDetails tv of - MetaTv SigTv _ -> False - _ -> True + MetaTv { mtv_info = SigTv } -> False + _ -> True isSkolemTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -737,19 +821,40 @@ isMetaTyVarTy :: TcType -> Bool isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv isMetaTyVarTy _ = False +metaTyVarInfo :: TcTyVar -> MetaInfo +metaTyVarInfo tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = info } -> info + _ -> pprPanic "metaTyVarInfo" (ppr tv) + +metaTyVarUntouchables :: TcTyVar -> Untouchables +metaTyVarUntouchables tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + MetaTv { mtv_untch = untch } -> untch + _ -> pprPanic "metaTyVarUntouchables" (ppr tv) + +setMetaTyVarUntouchables :: TcTyVar -> Untouchables -> TcTyVar +setMetaTyVarUntouchables tv untch + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_untch = untch }) + _ -> pprPanic "metaTyVarUntouchables" (ppr tv) + isSigTyVar :: Var -> Bool isSigTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - MetaTv SigTv _ -> True - _ -> False + MetaTv { mtv_info = SigTv } -> True + _ -> False metaTvRef :: TyVar -> IORef MetaDetails metaTvRef tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of - MetaTv _ ref -> ref - _ -> pprPanic "metaTvRef" (ppr tv) + MetaTv { mtv_ref = ref } -> ref + _ -> pprPanic "metaTvRef" (ppr tv) isFlexi, isIndirect :: MetaDetails -> Bool isFlexi Flexi = True @@ -811,8 +916,8 @@ isTauTy _ = False isTauTyCon :: TyCon -> Bool -- Returns False for type synonyms whose expansion is a polytype isTauTyCon tc - | isClosedSynTyCon tc = isTauTy (snd (synTyConDefn tc)) - | otherwise = True + | Just (_, rhs) <- synTyConDefn_maybe tc = isTauTy rhs + | otherwise = True --------------- getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to @@ -1270,6 +1375,7 @@ orphNamesOfCo (UnsafeCo ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNa orphNamesOfCo (SymCo co) = orphNamesOfCo co orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2 orphNamesOfCo (NthCo _ co) = orphNamesOfCo co +orphNamesOfCo (LRCo _ co) = orphNamesOfCo co orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty orphNamesOfCos :: [Coercion] -> NameSet diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 6f92ccbd35..781d4c8cd1 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -19,7 +19,8 @@ module TcUnify ( checkConstraints, newImplication, -- Various unifications - unifyType, unifyTypeList, unifyTheta, unifyKind, unifyKindEq, + unifyType, unifyTypeList, unifyTheta, + unifyKindX, -------------------------------- -- Holes @@ -59,7 +60,7 @@ import VarEnv import ErrUtils import DynFlags import BasicTypes -import Maybes ( allMaybes ) +import Maybes ( allMaybes, isJust ) import Util import Outputable import FastString @@ -424,11 +425,12 @@ newImplication :: SkolemInfo -> [TcTyVar] newImplication skol_info skol_tvs given thing_inside = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs ) ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) - do { ((result, untch), wanted) <- captureConstraints $ + do { let no_equalities = not (hasEqualities given) + ; ((result, untch), wanted) <- captureConstraints $ captureUntouchables $ thing_inside - ; if isEmptyWC wanted && not (hasEqualities given) + ; if isEmptyWC wanted && no_equalities -- Optimisation : if there are no wanteds, and the givens -- are sufficiently simple, don't generate an implication -- at all. Reason for the hasEqualities test: @@ -438,16 +440,16 @@ newImplication skol_info skol_tvs given thing_inside return (emptyTcEvBinds, result) else do { ev_binds_var <- newTcEvBinds - ; lcl_env <- getLclTypeEnv - ; loc <- getCtLoc skol_info + ; env <- getLclEnv ; emitImplication $ Implic { ic_untch = untch - , ic_env = lcl_env , ic_skols = skol_tvs + , ic_fsks = [] , ic_given = given , ic_wanted = wanted , ic_insol = insolubleWC wanted , ic_binds = ev_binds_var - , ic_loc = loc } + , ic_env = env + , ic_info = skol_info } ; return (TcEvBinds ev_binds_var, result) } } \end{code} @@ -465,7 +467,9 @@ non-exported generic functions. unifyType :: TcTauType -> TcTauType -> TcM TcCoercion -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 -unifyType ty1 ty2 = uType [] ty1 ty2 +unifyType ty1 ty2 = uType origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 } --------------- unifyPred :: PredType -> PredType -> TcM TcCoercion @@ -507,21 +511,9 @@ second, except that if the first is a synonym then the second may be a de-synonym'd version. This way we get better error messages. \begin{code} -data SwapFlag - = NotSwapped -- Args are: actual, expected - | IsSwapped -- Args are: expected, actual - -instance Outputable SwapFlag where - ppr IsSwapped = ptext (sLit "Is-swapped") - ppr NotSwapped = ptext (sLit "Not-swapped") - -unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b -unSwap NotSwapped f a b = f a b -unSwap IsSwapped f a b = f b a - ------------ -uType, uType_np, uType_defer - :: [EqOrigin] +uType, uType_defer + :: CtOrigin -> TcType -- ty1 is the *actual* type -> TcType -- ty2 is the *expected* type -> TcM TcCoercion @@ -529,13 +521,12 @@ uType, uType_np, uType_defer -------------- -- It is always safe to defer unification to the main constraint solver -- See Note [Deferred unification] -uType_defer items ty1 ty2 - = ASSERT( not (null items) ) - do { eqv <- newEq ty1 ty2 - ; loc <- getCtLoc (TypeEqOrigin (last items)) - ; let ctev = Wanted { ctev_wloc = loc, ctev_evar = eqv - , ctev_pred = mkTcEqPred ty1 ty2 } - ; emitFlat $ mkNonCanonical ctev +uType_defer origin ty1 ty2 + = do { eqv <- newEq ty1 ty2 + ; loc <- getCtLoc origin + ; let ctev = CtWanted { ctev_evar = eqv + , ctev_pred = mkTcEqPred ty1 ty2 } + ; emitFlat $ mkNonCanonical loc ctev -- Error trace only -- NB. do *not* call mkErrInfo unless tracing is on, because @@ -544,20 +535,17 @@ uType_defer items ty1 ty2 { ctxt <- getErrCtxt ; doc <- mkErrInfo emptyTidyEnv ctxt ; traceTc "utype_defer" (vcat [ppr eqv, ppr ty1, - ppr ty2, ppr items, doc]) + ppr ty2, ppr origin, doc]) } ; return (mkTcCoVarCo eqv) } -------------- --- Push a new item on the origin stack (the most common case) -uType origin ty1 ty2 -- Push a new item on the origin stack - = uType_np (pushOrigin ty1 ty2 origin) ty1 ty2 - --------------- -- unify_np (short for "no push" on the origin stack) does the work -uType_np origin orig_ty1 orig_ty2 - = do { traceTc "u_tys " $ vcat - [ sep [ ppr orig_ty1, text "~", ppr orig_ty2] +uType origin orig_ty1 orig_ty2 + = do { untch <- getUntouchables + ; traceTc "u_tys " $ vcat + [ text "untch" <+> ppr untch + , sep [ ppr orig_ty1, text "~", ppr orig_ty2] , ppr origin] ; co <- go orig_ty1 orig_ty2 ; if isTcReflCo co @@ -644,11 +632,11 @@ uType_np origin orig_ty1 orig_ty2 ------------------ go_app s1 t1 s2 t2 - = do { co_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] + = do { co_s <- uType origin s1 s2 -- See Note [Unifying AppTy] ; co_t <- uType origin t1 t2 ; return $ mkTcAppCo co_s co_t } -unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM TcCoercion +unifySigmaTy :: CtOrigin -> TcType -> TcType -> TcM TcCoercion unifySigmaTy origin ty1 ty2 = do { let (tvs1, body1) = tcSplitForAllTys ty1 (tvs2, body2) = tcSplitForAllTys ty2 @@ -755,7 +743,7 @@ of the substitution; rather, notice that @uVar@ (defined below) nips back into @uTys@ if it turns out that the variable is already bound. \begin{code} -uUnfilledVar :: [EqOrigin] +uUnfilledVar :: CtOrigin -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTauType -- Type 2 @@ -776,10 +764,12 @@ uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2) uUnfilledVar origin swapped tv1 details1 non_var_ty2 -- ty2 is not a type variable = case details1 of - MetaTv TauTv ref1 + MetaTv { mtv_info = TauTv, mtv_ref = ref1 } -> do { mb_ty2' <- checkTauTvUpdate tv1 non_var_ty2 ; case mb_ty2' of - Nothing -> do { traceTc "Occ/kind defer" (ppr tv1); defer } + Nothing -> do { traceTc "Occ/kind defer" (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) + $$ ppr non_var_ty2 $$ ppr (typeKind non_var_ty2)) + ; defer } Just ty2' -> updateMeta tv1 ref1 ty2' } @@ -795,7 +785,7 @@ uUnfilledVar origin swapped tv1 details1 non_var_ty2 -- ty2 is not a type varia -- eg tv1 occured in type family parameter ---------------- -uUnfilledVars :: [EqOrigin] +uUnfilledVars :: CtOrigin -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTyVar -> TcTyVarDetails -- Tyvar 2 @@ -806,31 +796,34 @@ uUnfilledVars :: [EqOrigin] uUnfilledVars origin swapped tv1 details1 tv2 details2 = do { traceTc "uUnfilledVars" ( text "trying to unify" <+> ppr k1 <+> text "with" <+> ppr k2) - ; let ctxt = mkKindErrorCtxt ty1 ty2 k1 k2 - ; sub_kind <- addErrCtxtM ctxt $ unifyKind k1 k2 + ; mb_sub_kind <- unifyKindX k1 k2 + ; case mb_sub_kind of { + Nothing -> unSwap swapped (uType_defer origin) (mkTyVarTy tv1) ty2 ; + Just sub_kind -> - ; case (sub_kind, details1, details2) of + case (sub_kind, details1, details2) of -- k1 < k2, so update tv2 - (LT, _, MetaTv _ ref2) -> updateMeta tv2 ref2 ty1 + (LT, _, MetaTv { mtv_ref = ref2 }) -> updateMeta tv2 ref2 ty1 -- k2 < k1, so update tv1 - (GT, MetaTv _ ref1, _) -> updateMeta tv1 ref1 ty2 + (GT, MetaTv { mtv_ref = ref1 }, _) -> updateMeta tv1 ref1 ty2 -- k1 = k2, so we are free to update either way - (EQ, MetaTv i1 ref1, MetaTv i2 ref2) + (EQ, MetaTv { mtv_info = i1, mtv_ref = ref1 }, + MetaTv { mtv_info = i2, mtv_ref = ref2 }) | nicer_to_update_tv1 i1 i2 -> updateMeta tv1 ref1 ty2 | otherwise -> updateMeta tv2 ref2 ty1 - (EQ, MetaTv _ ref1, _) -> updateMeta tv1 ref1 ty2 - (EQ, _, MetaTv _ ref2) -> updateMeta tv2 ref2 ty1 + (EQ, MetaTv { mtv_ref = ref1 }, _) -> updateMeta tv1 ref1 ty2 + (EQ, _, MetaTv { mtv_ref = ref2 }) -> updateMeta tv2 ref2 ty1 -- Can't do it in-place, so defer -- This happens for skolems of all sorts - (_, _, _) -> unSwap swapped (uType_defer origin) ty1 ty2 } + (_, _, _) -> unSwap swapped (uType_defer origin) ty1 ty2 } } where - k1 = tyVarKind tv1 - k2 = tyVarKind tv2 - ty1 = mkTyVarTy tv1 - ty2 = mkTyVarTy tv2 + k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + ty1 = mkTyVarTy tv1 + ty2 = mkTyVarTy tv2 nicer_to_update_tv1 _ SigTv = True nicer_to_update_tv1 SigTv _ = False @@ -863,17 +856,21 @@ checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType) -- we return Nothing, leaving it to the later constraint simplifier to -- sort matters out. -checkTauTvUpdate tv ty - = do { ty' <- zonkTcType ty - ; let k2 = typeKind ty' - ; k1 <- zonkTcKind (tyVarKind tv) - ; let ctxt = mkKindErrorCtxt (mkTyVarTy tv) ty' k1 k2 - ; sub_k <- addErrCtxtM ctxt $ - unifyKind (tyVarKind tv) (typeKind ty') +-- Used in debug meesages only +_ppr_sub :: Maybe Ordering -> SDoc +_ppr_sub (Just LT) = text "LT" +_ppr_sub (Just EQ) = text "EQ" +_ppr_sub (Just GT) = text "GT" +_ppr_sub Nothing = text "Nothing" +checkTauTvUpdate tv ty + = do { ty' <- zonkTcType ty + ; sub_k <- unifyKindX (tyVarKind tv) (typeKind ty') +-- ; traceTc "checktttv" (ppr tv $$ ppr ty' $$ ppr (tyVarKind tv) $$ ppr (typeKind ty') $$ _ppr_sub sub_k) ; case sub_k of - LT -> return Nothing - _ -> return (ok ty') } + Nothing -> return Nothing + Just LT -> return Nothing + _ -> return (ok ty') } where ok :: TcType -> Maybe TcType -- Checks that tv does not occur in the arg type @@ -933,7 +930,7 @@ function @occ_check_ok@. Note [Type family sharing] -~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~ We must avoid eagerly unifying type variables to types that contain function symbols, because this may lead to loss of sharing, and in turn, in very poor performance of the constraint simplifier. Assume that we have a wanted constraint: @@ -967,15 +964,16 @@ data LookupTyVarResult -- The result of a lookupTcTyVar call lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult lookupTcTyVar tyvar - | MetaTv _ ref <- details + | MetaTv { mtv_ref = ref } <- details = do { meta_details <- readMutVar ref ; case meta_details of Indirect ty -> return (Filled ty) - Flexi -> do { is_untch <- isUntouchable tyvar - ; let -- Note [Unifying untouchables] - ret_details | is_untch = vanillaSkolemTv - | otherwise = details - ; return (Unfilled ret_details) } } + Flexi -> do { is_touchable <- isTouchableTcM tyvar + -- Note [Unifying untouchables] + ; if is_touchable then + return (Unfilled details) + else + return (Unfilled vanillaSkolemTv) } } | otherwise = return (Unfilled details) where @@ -997,50 +995,6 @@ we return a made-up TcTyVarDetails, but I think it works smoothly. %************************************************************************ %* * - Errors and contexts -%* * -%************************************************************************ - -\begin{code} -pushOrigin :: TcType -> TcType -> [EqOrigin] -> [EqOrigin] -pushOrigin ty_act ty_exp origin - = UnifyOrigin { uo_actual = ty_act, uo_expected = ty_exp } : origin -\end{code} - - ------------------------------------------ - UNUSED FOR NOW ------------------------------------------ - ----------------- ----------------- --- If an error happens we try to figure out whether the function --- function has been given too many or too few arguments, and say so. -addSubCtxt :: InstOrigin -> TcType -> TcType -> TcM a -> TcM a -addSubCtxt orig actual_res_ty expected_res_ty thing_inside - = addErrCtxtM mk_err thing_inside - where - mk_err tidy_env - = do { exp_ty' <- zonkTcType expected_res_ty - ; act_ty' <- zonkTcType actual_res_ty - ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty' - (env2, act_ty'') = tidyOpenType env1 act_ty' - (exp_args, _) = tcSplitFunTys exp_ty'' - (act_args, _) = tcSplitFunTys act_ty'' - - len_act_args = length act_args - len_exp_args = length exp_args - - message = case orig of - OccurrenceOf fun - | len_exp_args < len_act_args -> wrongArgsCtxt "too few" fun - | len_exp_args > len_act_args -> wrongArgsCtxt "too many" fun - _ -> mkExpectedActualMsg act_ty'' exp_ty'' - ; return (env2, message) } - - -%************************************************************************ -%* * Kind unification %* * %************************************************************************ @@ -1059,63 +1013,66 @@ happy to have types of kind Constraint on either end of an arrow. matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind)) -- Like unifyFunTy, but does not fail; instead just returns Nothing -matchExpectedFunKind (TyVarTy kvar) = do - maybe_kind <- readMetaTyVar kvar - case maybe_kind of - Indirect fun_kind -> matchExpectedFunKind fun_kind - Flexi -> - do { arg_kind <- newMetaKindVar - ; res_kind <- newMetaKindVar - ; writeMetaTyVar kvar (mkArrowKind arg_kind res_kind) - ; return (Just (arg_kind,res_kind)) } +matchExpectedFunKind (FunTy arg_kind res_kind) + = return (Just (arg_kind,res_kind)) -matchExpectedFunKind (FunTy arg_kind res_kind) = return (Just (arg_kind,res_kind)) -matchExpectedFunKind _ = return Nothing +matchExpectedFunKind (TyVarTy kvar) + | isTcTyVar kvar, isMetaTyVar kvar + = do { maybe_kind <- readMetaTyVar kvar + ; case maybe_kind of + Indirect fun_kind -> matchExpectedFunKind fun_kind + Flexi -> + do { arg_kind <- newMetaKindVar + ; res_kind <- newMetaKindVar + ; writeMetaTyVar kvar (mkArrowKind arg_kind res_kind) + ; return (Just (arg_kind,res_kind)) } } ------------------ -unifyKind :: TcKind -- k1 (actual) - -> TcKind -- k2 (expected) - -> TcM Ordering -- Returns the relation between the kinds - -- LT <=> k1 is a sub-kind of k2 +matchExpectedFunKind _ = return Nothing --- unifyKind deals with the top-level sub-kinding story +----------------- +unifyKindX :: TcKind -- k1 (actual) + -> TcKind -- k2 (expected) + -> TcM (Maybe Ordering) + -- Returns the relation between the kinds + -- Just LT <=> k1 is a sub-kind of k2 + -- Nothing <=> incomparable + +-- unifyKindX deals with the top-level sub-kinding story -- but recurses into the simpler unifyKindEq for any sub-terms -- The sub-kinding stuff only applies at top level -unifyKind (TyVarTy kv1) k2 = uKVar False unifyKind EQ kv1 k2 -unifyKind k1 (TyVarTy kv2) = uKVar True unifyKind EQ kv2 k1 +unifyKindX (TyVarTy kv1) k2 = uKVar NotSwapped unifyKindX kv1 k2 +unifyKindX k1 (TyVarTy kv2) = uKVar IsSwapped unifyKindX kv2 k1 -unifyKind k1 k2 -- See Note [Expanding synonyms during unification] - | Just k1' <- tcView k1 = unifyKind k1' k2 - | Just k2' <- tcView k2 = unifyKind k1 k2' +unifyKindX k1 k2 -- See Note [Expanding synonyms during unification] + | Just k1' <- tcView k1 = unifyKindX k1' k2 + | Just k2' <- tcView k2 = unifyKindX k1 k2' -unifyKind k1@(TyConApp kc1 []) k2@(TyConApp kc2 []) - | kc1 == kc2 = return EQ - | kc1 `tcIsSubKindCon` kc2 = return LT - | kc2 `tcIsSubKindCon` kc1 = return GT - | otherwise = unifyKindMisMatch k1 k2 +unifyKindX (TyConApp kc1 []) (TyConApp kc2 []) + | kc1 == kc2 = return (Just EQ) + | kc1 `tcIsSubKindCon` kc2 = return (Just LT) + | kc2 `tcIsSubKindCon` kc1 = return (Just GT) + | otherwise = return Nothing -unifyKind k1 k2 = do { unifyKindEq k1 k2; return EQ } +unifyKindX k1 k2 = unifyKindEq k1 k2 -- In all other cases, let unifyKindEq do the work -uKVar :: Bool -> (TcKind -> TcKind -> TcM a) -> a - -> MetaKindVar -> TcKind -> TcM a -uKVar isFlipped unify_kind eq_res kv1 k2 +uKVar :: SwapFlag -> (TcKind -> TcKind -> TcM (Maybe Ordering)) + -> MetaKindVar -> TcKind -> TcM (Maybe Ordering) +uKVar swapped unify_kind kv1 k2 | isTcTyVar kv1, isMetaTyVar kv1 -- See Note [Unifying kind variables] = do { mb_k1 <- readMetaTyVar kv1 ; case mb_k1 of - Flexi -> do { uUnboundKVar kv1 k2; return eq_res } - Indirect k1 -> if isFlipped then unify_kind k2 k1 - else unify_kind k1 k2 } + Flexi -> uUnboundKVar kv1 k2 + Indirect k1 -> unSwap swapped unify_kind k1 k2 } | TyVarTy kv2 <- k2, kv1 == kv2 - = return eq_res + = return (Just EQ) | TyVarTy kv2 <- k2, isTcTyVar kv2, isMetaTyVar kv2 - = uKVar (not isFlipped) unify_kind eq_res kv2 (TyVarTy kv1) + = uKVar (flipSwap swapped) unify_kind kv2 (TyVarTy kv1) - | otherwise = if isFlipped - then unifyKindMisMatch k2 (TyVarTy kv1) - else unifyKindMisMatch (TyVarTy kv1) k2 + | otherwise + = return Nothing {- Note [Unifying kind variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1133,49 +1090,49 @@ Hence the isTcTyVar tests before using isMetaTyVar. -} --------------------------- -unifyKindEq :: TcKind -> TcKind -> TcM () -unifyKindEq (TyVarTy kv1) k2 = uKVar False unifyKindEq () kv1 k2 -unifyKindEq k1 (TyVarTy kv2) = uKVar True unifyKindEq () kv2 k1 +unifyKindEq :: TcKind -> TcKind -> TcM (Maybe Ordering) +-- Unify two kinds looking for equality not sub-kinding +-- So it returns Nothing or (Just EQ) only +unifyKindEq (TyVarTy kv1) k2 = uKVar NotSwapped unifyKindEq kv1 k2 +unifyKindEq k1 (TyVarTy kv2) = uKVar IsSwapped unifyKindEq kv2 k1 unifyKindEq (FunTy a1 r1) (FunTy a2 r2) - = do { unifyKindEq a1 a2; unifyKindEq r1 r2 } + = do { mb1 <- unifyKindEq a1 a2; mb2 <- unifyKindEq r1 r2 + ; return (if isJust mb1 && isJust mb2 then Just EQ else Nothing) } unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s) | kc1 == kc2 = ASSERT (length k1s == length k2s) -- Should succeed since the kind constructors are the same, -- and the kinds are sort-checked, thus fully applied - zipWithM_ unifyKindEq k1s k2s + do { mb_eqs <- zipWithM unifyKindEq k1s k2s + ; return (if all isJust mb_eqs + then Just EQ + else Nothing) } -unifyKindEq k1 k2 = unifyKindMisMatch k1 k2 +unifyKindEq _ _ = return Nothing ---------------- -uUnboundKVar :: MetaKindVar -> TcKind -> TcM () +uUnboundKVar :: MetaKindVar -> TcKind -> TcM (Maybe Ordering) uUnboundKVar kv1 k2@(TyVarTy kv2) - | kv1 == kv2 = return () + | kv1 == kv2 = return (Just EQ) | isTcTyVar kv2, isMetaTyVar kv2 -- Distinct kind variables = do { mb_k2 <- readMetaTyVar kv2 ; case mb_k2 of Indirect k2 -> uUnboundKVar kv1 k2 - Flexi -> writeMetaTyVar kv1 k2 } - | otherwise = writeMetaTyVar kv1 k2 + Flexi -> do { writeMetaTyVar kv1 k2; return (Just EQ) } } + | otherwise + = do { writeMetaTyVar kv1 k2; return (Just EQ) } uUnboundKVar kv1 non_var_k2 = do { k2' <- zonkTcKind non_var_k2 ; let k2'' = defaultKind k2' -- MetaKindVars must be bound only to simple kinds - ; kindUnifCheck kv1 k2'' - ; writeMetaTyVar kv1 k2'' } ----------------- -kindUnifCheck :: TyVar -> Type -> TcM () -kindUnifCheck kv1 k2 -- k2 is zonked - | elemVarSet kv1 (tyVarsOfType k2) - = failWithTc (kindOccurCheckErr kv1 k2) - | isSigTyVar kv1 - = failWithTc (kindSigVarErr kv1 k2) - | otherwise - = return () + ; if not (elemVarSet kv1 (tyVarsOfType k2'')) + && not (isSigTyVar kv1) + then do { writeMetaTyVar kv1 k2''; return (Just EQ) } + else return Nothing } mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) mkKindErrorCtxt ty1 ty2 k1 k2 env0 @@ -1188,28 +1145,7 @@ mkKindErrorCtxt ty1 ty2 k1 k2 env0 k1 <- zonkTcKind k1' k2 <- zonkTcKind k2' return (env4, - vcat [ ptext (sLit "Kind incompatibility when matching types:") + vcat [ ptext (sLit "Kind incompatibility when matching types xx:") , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]) - -unifyKindMisMatch :: TcKind -> TcKind -> TcM a -unifyKindMisMatch ki1 ki2 = do - ki1' <- zonkTcKind ki1 - ki2' <- zonkTcKind ki2 - let msg = hang (ptext (sLit "Couldn't match kind")) - 2 (sep [quotes (ppr ki1'), - ptext (sLit "against"), - quotes (ppr ki2')]) - failWithTc msg - ----------------- -kindOccurCheckErr :: Var -> Type -> SDoc -kindOccurCheckErr tyvar ty - = hang (ptext (sLit "Occurs check: cannot construct the infinite kind:")) - 2 (sep [ppr tyvar, char '=', ppr ty]) - -kindSigVarErr :: Var -> Type -> SDoc -kindSigVarErr tv ty - = hang (ptext (sLit "Cannot unify the kind variable") <+> quotes (ppr tv)) - 2 (ptext (sLit "with the kind") <+> quotes (ppr ty)) \end{code} diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot index 4d07229963..aa93536705 100644 --- a/compiler/typecheck/TcUnify.lhs-boot +++ b/compiler/typecheck/TcUnify.lhs-boot @@ -1,6 +1,6 @@ \begin{code} module TcUnify where -import TcType ( TcTauType, TcKind, Type, Kind ) +import TcType ( TcTauType, Type, Kind ) import VarEnv ( TidyEnv ) import TcRnTypes ( TcM ) import TcEvidence ( TcCoercion ) @@ -10,6 +10,5 @@ import Outputable ( SDoc ) -- TcUnify and Inst unifyType :: TcTauType -> TcTauType -> TcM TcCoercion -unifyKindEq :: TcKind -> TcKind -> TcM () mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) \end{code} diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 42e54ba47b..4599ddf04a 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -17,6 +17,7 @@ module Coercion ( -- * Main data type Coercion(..), Var, CoVar, + LeftOrRight(..), pickLR, -- ** Functions over coercions coVarKind, @@ -31,7 +32,7 @@ module Coercion ( mkReflCo, mkCoVarCo, mkAxInstCo, mkAxInstRHS, mkPiCo, mkPiCos, mkCoCast, - mkSymCo, mkTransCo, mkNthCo, + mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo, mkForAllCo, mkUnsafeCo, mkNewTypeCo, @@ -148,9 +149,17 @@ data Coercion | TransCo Coercion Coercion -- These are destructors - | NthCo Int Coercion -- Zero-indexed + | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + | LRCo LeftOrRight Coercion -- Decomposes (t_left t_right) | InstCo Coercion Type deriving (Data.Data, Data.Typeable) + +data LeftOrRight = CLeft | CRight + deriving( Eq, Data.Data, Data.Typeable ) + +pickLR :: LeftOrRight -> (a,a) -> a +pickLR CLeft (l,_) = l +pickLR CRight (_,r) = r \end{code} @@ -337,6 +346,7 @@ tyCoVarsOfCo (UnsafeCo ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType t tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 tyCoVarsOfCo (NthCo _ co) = tyCoVarsOfCo co +tyCoVarsOfCo (LRCo _ co) = tyCoVarsOfCo co tyCoVarsOfCo (InstCo co ty) = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty tyCoVarsOfCos :: [Coercion] -> VarSet @@ -354,6 +364,7 @@ coVarsOfCo (UnsafeCo _ _) = emptyVarSet coVarsOfCo (SymCo co) = coVarsOfCo co coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 coVarsOfCo (NthCo _ co) = coVarsOfCo co +coVarsOfCo (LRCo _ co) = coVarsOfCo co coVarsOfCo (InstCo co _) = coVarsOfCo co coVarsOfCos :: [Coercion] -> VarSet @@ -370,6 +381,7 @@ coercionSize (UnsafeCo ty1 ty2) = typeSize ty1 + typeSize ty2 coercionSize (SymCo co) = 1 + coercionSize co coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 coercionSize (NthCo _ co) = 1 + coercionSize co +coercionSize (LRCo _ co) = 1 + coercionSize co coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty \end{code} @@ -404,20 +416,29 @@ ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ pprCo co1 <+> ppr_co TyConPrec co2 ppr_co p co@(ForAllCo {}) = ppr_forall_co p co ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) -ppr_co p (AxiomInstCo con cos) = angleBrackets (pprTypeNameApp p ppr_co (getName con) cos) +ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos -ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $ - ppr_co FunPrec co1 - <+> ptext (sLit ";") - <+> ppr_co FunPrec co2 +ppr_co p co@(TransCo {}) = maybeParen p FunPrec $ + case trans_co_list co [] of + [] -> panic "ppr_co" + (co:cos) -> sep ( ppr_co FunPrec co + : [ char ';' <+> ppr_co FunPrec co | co <- cos]) ppr_co p (InstCo co ty) = maybeParen p TyConPrec $ pprParendCo co <> ptext (sLit "@") <> pprType ty ppr_co p (UnsafeCo ty1 ty2) = pprPrefixApp p (ptext (sLit "UnsafeCo")) [pprParendType ty1, pprParendType ty2] ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co] -ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendCo co] +ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co] +ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co] + +trans_co_list :: Coercion -> [Coercion] -> [Coercion] +trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos) +trans_co_list co cos = co : cos +instance Outputable LeftOrRight where + ppr CLeft = ptext (sLit "Left") + ppr CRight = ptext (sLit "Right") ppr_fun_co :: Prec -> Coercion -> SDoc ppr_fun_co p co = pprArrowChain p (split co) @@ -625,6 +646,10 @@ mkNthCo n co = ASSERT( ok_tc_app _ty1 n && ok_tc_app _ty2 n ) where Pair _ty1 _ty2 = coercionKind co +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkLRCo lr (Refl ty) = Refl (pickLR lr (splitAppTy ty)) +mkLRCo lr co = LRCo lr co + ok_tc_app :: Type -> Int -> Bool ok_tc_app ty n = case splitTyConApp_maybe ty of Just (_, tys) -> tys `lengthExceeds` n @@ -759,6 +784,8 @@ coreEqCoercion2 env (TransCo co11 co12) (TransCo co21 co22) coreEqCoercion2 env (NthCo d1 co1) (NthCo d2 co2) = d1 == d2 && coreEqCoercion2 env co1 co2 +coreEqCoercion2 env (LRCo d1 co1) (LRCo d2 co2) + = d1 == d2 && coreEqCoercion2 env co1 co2 coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2) = coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2 @@ -900,6 +927,7 @@ subst_co subst co go (SymCo co) = mkSymCo (go co) go (TransCo co1 co2) = mkTransCo (go co1) (go co2) go (NthCo d co) = mkNthCo d (go co) + go (LRCo lr co) = mkLRCo lr (go co) go (InstCo co ty) = mkInstCo (go co) $! go_ty ty substCoVar :: CvSubst -> CoVar -> Coercion @@ -1073,6 +1101,7 @@ seqCo (UnsafeCo ty1 ty2) = seqType ty1 `seq` seqType ty2 seqCo (SymCo co) = seqCo co seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 seqCo (NthCo _ co) = seqCo co +seqCo (LRCo _ co) = seqCo co seqCo (InstCo co ty) = seqCo co `seq` seqType ty seqCos :: [Coercion] -> () @@ -1114,6 +1143,7 @@ coercionKind co = go co go (SymCo co) = swap $ go co go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) go (NthCo d co) = tyConAppArgN d <$> go co + go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co go (InstCo aco ty) = go_app aco [ty] go_app :: Coercion -> [Type] -> Pair Type diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 388846b8ee..f99b0a1bdd 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -61,6 +61,10 @@ data ClsInst -- forall is_tvs. (...) => is_cls is_tys , is_dfun :: DFunId -- See Note [Haddock assumptions] + -- See Note [Silent superclass arguments] in TcInstDcls + -- for how to map the DFun's type back to the source + -- language instance decl + , is_flag :: OverlapFlag -- See detailed comments with -- the decl of BasicTypes.OverlapFlag } @@ -159,6 +163,7 @@ pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) let theta_to_print | debugStyle sty = theta | otherwise = drop (dfunNSilent dfun) theta + -- See Note [Silent superclass arguments] in TcInstDcls in ptext (sLit "instance") <+> ppr flag <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty] where diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index 7d707c33c4..a039fe5b3f 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -145,7 +145,7 @@ opt_co' env sym (TransCo co1 co2) opt_co' env sym (NthCo n co) | TyConAppCo tc cos <- co' - , isDecomposableTyCon tc -- Not synonym families + , isDecomposableTyCon tc -- Not synonym families = ASSERT( n < length cos ) cos !! n | otherwise @@ -153,6 +153,14 @@ opt_co' env sym (NthCo n co) where co' = opt_co env sym co +opt_co' env sym (LRCo lr co) + | Just pr_co <- splitAppCo_maybe co' + = pickLR lr pr_co + | otherwise + = LRCo lr co' + where + co' = opt_co env sym co + opt_co' env sym (InstCo co ty) -- See if the first arg is already a forall -- ...then we can just extend the current substitution @@ -165,7 +173,6 @@ opt_co' env sym (InstCo co ty) = substCoWithTy (getCvInScope env) tv ty' co'_body | otherwise = InstCo co' ty' - where co' = opt_co env sym co ty' = substTy env ty @@ -208,18 +215,19 @@ opt_trans2 _ co1 co2 -- Optimize coercions with a top-level use of transitivity. opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo --- push transitivity down through matching top-level constructors. -opt_trans_rule is in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2) - | tc1 == tc2 = fireTransRule "PushTyConApp" in_co1 in_co2 $ - TyConAppCo tc1 (opt_transList is cos1 cos2) - --- push transitivity through matching destructors +-- Push transitivity through matching destructors opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2) | d1 == d2 , co1 `compatible_co` co2 = fireTransRule "PushNth" in_co1 in_co2 $ mkNthCo d1 (opt_trans is co1 co2) +opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) + | d1 == d2 + , co1 `compatible_co` co2 + = fireTransRule "PushLR" in_co1 in_co2 $ + mkLRCo d1 (opt_trans is co1 co2) + -- Push transitivity inside instantiation opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) | ty1 `eqType` ty2 @@ -227,11 +235,17 @@ opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) = fireTransRule "TrPushInst" in_co1 in_co2 $ mkInstCo (opt_trans is co1 co2) ty1 --- Push transitivity inside apply +-- Push transitivity down through matching top-level constructors. +opt_trans_rule is in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2) + | tc1 == tc2 + = fireTransRule "PushTyConApp" in_co1 in_co2 $ + TyConAppCo tc1 (opt_transList is cos1 cos2) + opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) = fireTransRule "TrPushApp" in_co1 in_co2 $ mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) +-- Eta rules opt_trans_rule is co1@(TyConAppCo tc cos1) co2 | Just cos2 <- etaTyConAppCo_maybe tc co2 = ASSERT( length cos1 == length cos2 ) @@ -244,6 +258,16 @@ opt_trans_rule is co1 co2@(TyConAppCo tc cos2) fireTransRule "EtaCompR" co1 co2 $ TyConAppCo tc (opt_transList is cos1 cos2) +opt_trans_rule is co1@(AppCo co1a co1b) co2 + | Just (co2a,co2b) <- etaAppCo_maybe co2 + = fireTransRule "EtaAppL" co1 co2 $ + mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + +opt_trans_rule is co1 co2@(AppCo co2a co2b) + | Just (co1a,co1b) <- etaAppCo_maybe co1 + = fireTransRule "EtaAppR" co1 co2 $ + mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + -- Push transitivity inside forall opt_trans_rule is co1 co2 | Just (tv1,r1) <- splitForAllCo_maybe co1 @@ -359,6 +383,21 @@ etaForAllCo_maybe co | otherwise = Nothing +etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) +-- If possible, split a coercion +-- g :: t1a t1b ~ t2a t2b +-- into a pair of coercions (left g, right g) +etaAppCo_maybe co + | Just (co1,co2) <- splitAppCo_maybe co + = Just (co1,co2) + | Pair ty1 ty2 <- coercionKind co + , Just (_,t1) <- splitAppTy_maybe ty1 + , Just (_,t2) <- splitAppTy_maybe ty2 + , typeKind t1 `eqType` typeKind t2 -- Note [Eta for AppCo] + = Just (LRCo CLeft co, LRCo CRight co) + | otherwise + = Nothing + etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] -- If possible, split a coercion -- g :: T s1 .. sn ~ T t1 .. tn @@ -383,3 +422,25 @@ etaTyConAppCo_maybe tc co | otherwise = Nothing \end{code} + +Note [Eta for AppCo] +~~~~~~~~~~~~~~~~~~~~ +Supopse we have + g :: s1 t1 ~ s2 t2 + +Then we can't necessarily make + left g :: s1 ~ s2 + right g :: t1 ~ t2 +becuase it's poossible that + s1 :: * -> * t1 :: * + s2 :: (*->*) -> * t2 :: * -> * +and in that case (left g) does not have the same +kind on either side. + +It's enough to check that + kind t1 = kind t2 +because if g is well-kinded then + kind (s1 t2) = kind (s2 t2) +and these two imply + kind s1 = kind s2 + diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 06fef36102..5919779703 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -12,7 +12,7 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, TyConParent(..), isNoParent, - SynTyConRhs(..), + SynTyConRhs(..), -- ** Coercion axiom constructors CoAxiom(..), @@ -38,10 +38,11 @@ module TyCon( isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isSynTyCon, isClosedSynTyCon, + isSynTyCon, isOpenSynFamilyTyCon, isDecomposableTyCon, isForeignTyCon, isPromotedDataCon, isPromotedTyCon, + isPromotedDataCon_maybe, isPromotedTyCon_maybe, isInjectiveTyCon, isDataTyCon, isProductTyCon, isEnumerationTyCon, @@ -66,12 +67,11 @@ module TyCon( tyConParent, tyConTuple_maybe, tyConClass_maybe, tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, - synTyConDefn, synTyConRhs, synTyConType, + synTyConDefn_maybe, synTyConRhs_maybe, tyConExtName, -- External name for foreign types algTyConRhs, newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, tupleTyConBoxity, tupleTyConSort, tupleTyConArity, - promotedDataCon, promotedTyCon, -- ** Manipulating TyCons tcExpandTyCon_maybe, coreExpandTyCon_maybe, @@ -359,8 +359,8 @@ data TyCon tyConTyVars :: [TyVar], -- Bound tyvars - synTcRhs :: SynTyConRhs, -- ^ Contains information about the - -- expansion of the synonym + synTcRhs :: SynTyConRhs Type, -- ^ Contains information about the + -- expansion of the synonym synTcParent :: TyConParent -- ^ Gives the family declaration 'TyCon' -- of 'TyCon's representing family instances @@ -566,17 +566,28 @@ isNoParent _ = False -------------------- -- | Information pertaining to the expansion of a type synonym (@type@) -data SynTyConRhs +data SynTyConRhs ty = -- | An ordinary type synonyn. SynonymTyCon - Type -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. + ty -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. -- It acts as a template for the expansion when the 'TyCon' -- is applied to some types. -- | A type synonym family e.g. @type family F x y :: * -> *@ - | SynFamilyTyCon + | SynFamilyTyCon { + synf_open :: Bool, -- See Note [Closed type families] + synf_injective :: Bool + } \end{code} +Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +* In an open type family you can add new instances later. This is the + usual case. + +* In a closed type family you can only put instnaces where the family + is defined. GHC doesn't support syntax for this yet. + Note [Promoted data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A data constructor can be promoted to become a type constructor, @@ -918,7 +929,7 @@ mkPrimTyCon' name kind arity rep is_unlifted } -- | Create a type synonym 'TyCon' -mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs -> TyConParent -> TyCon +mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs Type -> TyConParent -> TyCon mkSynTyCon name kind tyvars rhs parent = SynTyCon { tyConName = name, @@ -1106,15 +1117,15 @@ isSynFamilyTyCon :: TyCon -> Bool isSynFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon {}}) = True isSynFamilyTyCon _ = False +isOpenSynFamilyTyCon :: TyCon -> Bool +isOpenSynFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon { synf_open = is_open } }) = is_open +isOpenSynFamilyTyCon _ = False + -- | Is this a synonym 'TyCon' that can have may have further instances appear? isDataFamilyTyCon :: TyCon -> Bool isDataFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True isDataFamilyTyCon _ = False --- | Is this a synonym 'TyCon' that can have no further instances appear? -isClosedSynTyCon :: TyCon -> Bool -isClosedSynTyCon tycon = isSynTyCon tycon && not (isFamilyTyCon tycon) - -- | Injective 'TyCon's can be decomposed, so that -- T ty1 ~ T ty2 => ty1 ~ ty2 isInjectiveTyCon :: TyCon -> Bool @@ -1184,25 +1195,25 @@ isForeignTyCon :: TyCon -> Bool isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True isForeignTyCon _ = False --- | Is this a PromotedDataCon? -isPromotedDataCon :: TyCon -> Bool -isPromotedDataCon (PromotedDataCon {}) = True -isPromotedDataCon _ = False - -- | Is this a PromotedTyCon? isPromotedTyCon :: TyCon -> Bool isPromotedTyCon (PromotedTyCon {}) = True isPromotedTyCon _ = False --- | Retrieves the promoted DataCon if this is a PromotedDataTyCon; --- Panics otherwise -promotedDataCon :: TyCon -> DataCon -promotedDataCon = dataCon +-- | Retrieves the promoted TyCon if this is a PromotedTyCon; +isPromotedTyCon_maybe :: TyCon -> Maybe TyCon +isPromotedTyCon_maybe (PromotedTyCon { ty_con = tc }) = Just tc +isPromotedTyCon_maybe _ = Nothing --- | Retrieves the promoted TypeCon if this is a PromotedTypeTyCon; --- Panics otherwise -promotedTyCon :: TyCon -> TyCon -promotedTyCon = ty_con +-- | Is this a PromotedDataCon? +isPromotedDataCon :: TyCon -> Bool +isPromotedDataCon (PromotedDataCon {}) = True +isPromotedDataCon _ = False + +-- | Retrieves the promoted DataCon if this is a PromotedDataCon; +isPromotedDataCon_maybe :: TyCon -> Maybe DataCon +isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc +isPromotedDataCon_maybe _ = Nothing -- | Identifies implicit tycons that, in particular, do not go into interface -- files (because they are implicitly reconstructed when the interface is @@ -1351,26 +1362,17 @@ tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \end{code} \begin{code} --- | Extract the 'TyVar's bound by a type synonym and the corresponding (unsubstituted) right hand side. --- If the given 'TyCon' is not a type synonym, panics -synTyConDefn :: TyCon -> ([TyVar], Type) -synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) - = (tyvars, ty) -synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) - --- | Extract the information pertaining to the right hand side of a type synonym (@type@) declaration. Panics --- if the given 'TyCon' is not a type synonym -synTyConRhs :: TyCon -> SynTyConRhs -synTyConRhs (SynTyCon {synTcRhs = rhs}) = rhs -synTyConRhs tc = pprPanic "synTyConRhs" (ppr tc) - --- | Find the expansion of the type synonym represented by the given 'TyCon'. The free variables of this --- type will typically include those 'TyVar's bound by the 'TyCon'. Panics if the 'TyCon' is not that of --- a type synonym -synTyConType :: TyCon -> Type -synTyConType tc = case synTcRhs tc of - SynonymTyCon t -> t - _ -> pprPanic "synTyConType" (ppr tc) +-- | Extract the 'TyVar's bound by a vanilla type synonym (not familiy) +-- and the corresponding (unsubstituted) right hand side. +synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) +synTyConDefn_maybe (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) + = Just (tyvars, ty) +synTyConDefn_maybe _ = Nothing + +-- | Extract the information pertaining to the right hand side of a type synonym (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe (SynTyConRhs Type) +synTyConRhs_maybe (SynTyCon {synTcRhs = rhs}) = Just rhs +synTyConRhs_maybe _ = Nothing \end{code} \begin{code} diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 4e8e631015..57706612e2 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -54,7 +54,8 @@ module Type ( isDictLikeTy, mkEqPred, mkPrimEqPred, mkClassPred, - noParenPred, isClassPred, isEqPred, isIPPred, isIPPred_maybe, + noParenPred, isClassPred, isEqPred, + isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, -- Deconstructing predicate types PredTree(..), predTreePredType, classifyPredType, @@ -94,7 +95,7 @@ module Type ( -- * Type comparison eqType, eqTypeX, eqTypes, cmpType, cmpTypes, - eqPred, eqPredX, cmpPred, eqKind, + eqPred, eqPredX, cmpPred, eqKind, eqTyVarBndrs, -- * Forcing evaluation of types seqType, seqTypes, @@ -152,7 +153,7 @@ import Class import TyCon import TysPrim import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy ) -import PrelNames ( eqTyConKey, ipClassName ) +import PrelNames ( eqTyConKey, ipClassNameKey ) -- others import Unique ( Unique, hasKey ) @@ -857,13 +858,20 @@ isEqPred ty = case tyConAppTyCon_maybe ty of _ -> False isIPPred ty = case tyConAppTyCon_maybe ty of - Just tyCon -> tyConName tyCon == ipClassName - _ -> False + Just tc -> isIPTyCon tc + _ -> False + +isIPTyCon :: TyCon -> Bool +isIPTyCon tc = tc `hasKey` ipClassNameKey + +isIPClass :: Class -> Bool +isIPClass cls = cls `hasKey` ipClassNameKey + -- Class and it corresponding TyCon have the same Unique isIPPred_maybe :: Type -> Maybe (FastString, Type) isIPPred_maybe ty = do (tc,[t1,t2]) <- splitTyConApp_maybe ty - guard (tyConName tc == ipClassName) + guard (isIPTyCon tc) x <- isStrLitTy t1 return (x,t2) \end{code} @@ -875,7 +883,7 @@ Make PredTypes -- | Creates a type equality predicate mkEqPred :: Type -> Type -> PredType mkEqPred ty1 ty2 - = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 $$ ppr k $$ ppr (typeKind ty2) ) TyConApp eqTyCon [k, ty1, ty2] where k = typeKind ty1 @@ -1179,6 +1187,17 @@ eqPred = eqType eqPredX :: RnEnv2 -> PredType -> PredType -> Bool eqPredX env p1 p2 = isEqual $ cmpTypeX env p1 p2 + +eqTyVarBndrs :: RnEnv2 -> [TyVar] -> [TyVar] -> Maybe RnEnv2 +-- Check that the tyvar lists are the same length +-- and have matching kinds; if so, extend the RnEnv2 +-- Returns Nothing if they don't match +eqTyVarBndrs env [] [] + = Just env +eqTyVarBndrs env (tv1:tvs1) (tv2:tvs2) + | eqTypeX env (tyVarKind tv1) (tyVarKind tv2) + = eqTyVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 +eqTyVarBndrs _ _ _= Nothing \end{code} Now here comes the real worker @@ -1209,7 +1228,8 @@ cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2 -- So the RHS has a data type cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2 -cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 +cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX env (tyVarKind tv1) (tyVarKind tv1) + `thenCmp` cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 cmpTypeX env (AppTy s1 t1) (AppTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` cmpTypesX env tys1 tys2 diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 327ac78d71..00416154f2 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -53,7 +53,7 @@ module TypeRep ( #include "HsVersions.h" -import {-# SOURCE #-} DataCon( DataCon, dataConName ) +import {-# SOURCE #-} DataCon( DataCon, dataConTyCon, dataConName ) import {-# SOURCE #-} Type( noParenPred, isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop -- friends: @@ -668,8 +668,19 @@ pprTcApp p pp tc tys = pprPromotionQuote tc <> tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) + | Just dc <- isPromotedDataCon_maybe tc + , let dc_tc = dataConTyCon dc + , isTupleTyCon dc_tc + , let arity = tyConArity dc_tc -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3 + ty_args = drop arity tys -- Drop the kind args + , ty_args `lengthIs` arity -- Result is saturated + = pprPromotionQuote tc <> + (tupleParens (tupleTyConSort dc_tc) $ + sep (punctuate comma (map (pp TopPrec) ty_args))) + | not opt_PprStyle_Debug - , tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because + , getUnique tc `elem` [eqTyConKey, eqPrimTyConKey] + -- We need to special case the type equality TyCons because , [_, ty1,ty2] <- tys -- with kind polymorphism it has 3 args, so won't get printed infix -- With -dppr-debug switch this off so we can see the kind = pprInfixApp p pp (ppr tc) ty1 ty2 diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index d4a270dd0e..7b5a7aae44 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -51,7 +51,7 @@ module UniqFM ( foldUFM, foldUFM_Directly, mapUFM, mapUFM_Directly, elemUFM, elemUFM_Directly, - filterUFM, filterUFM_Directly, + filterUFM, filterUFM_Directly, partitionUFM, sizeUFM, isNullUFM, lookupUFM, lookupUFM_Directly, @@ -146,6 +146,7 @@ mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt +partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt) sizeUFM :: UniqFM elt -> Int --hashUFM :: UniqFM elt -> Int @@ -232,6 +233,8 @@ mapUFM f (UFM m) = UFM (M.map f m) mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) filterUFM p (UFM m) = UFM (M.filter p m) filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) +partitionUFM p (UFM m) = case M.partition p m of + (left, right) -> (UFM left, UFM right) sizeUFM (UFM m) = M.size m elemUFM k (UFM m) = M.member (getKey $ getUnique k) m diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml index 2425d822c9..e778c034d0 100644 --- a/docs/users_guide/ffi-chap.xml +++ b/docs/users_guide/ffi-chap.xml @@ -164,7 +164,7 @@ foreign import ccall interruptible <sect2 id="ffi-capi"> <title>The CAPI calling convention</title> <para> - The <literal>CAPI</literal> extension allows a calling + The <literal>CApiFFI</literal> extension allows a calling convention of <literal>capi</literal> to be used in foreign declarations, e.g. diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 1c2e76ee08..f5741997b0 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -3726,7 +3726,7 @@ We reuse the keyword <literal>default</literal> to signal that a signature applies to the default method only; when defining instances of the <literal>Enum</literal> class, the original type <literal>[a]</literal> of <literal>enum</literal> still applies. When giving an empty instance, however, -the default implementation <literal>map to0 genum</literal> is filled-in, +the default implementation <literal>map to genum</literal> is filled-in, and type-checked with the type <literal>(Generic a, GEnum (Rep a)) => [a]</literal>. </para> |