Refactor skolemising, and newClsInst
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 29 Oct 2014 16:26:53 +0000 (16:26 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 4 Nov 2014 10:37:57 +0000 (10:37 +0000)
This makes newClsInst (was mkInstance) look more like newFamInst, and simplifies
the plumbing of the overlap flag, and ensures that freshening (required by
the InstEnv stuff) happens in one place.

On the way I also tided up the rather ragged family of tcInstSkolTyVars and
friends.  The result at least has more uniform naming.

compiler/typecheck/FamInst.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcMType.lhs

index 016dc08..08b7e9d 100644 (file)
@@ -56,21 +56,17 @@ newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst
 -- Called from the vectoriser monad too, hence the rather general type
 newFamInst flavor axiom@(CoAxiom { co_ax_branches = FirstBranch branch
                                  , co_ax_tc = fam_tc })
-  = do { (subst, tvs') <- tcInstSigTyVarsLoc loc tvs
-       ; return (FamInst { fi_fam      = fam_tc_name
+  | CoAxBranch { cab_tvs = tvs
+               , cab_lhs = lhs
+               , cab_rhs = rhs } <- branch
+  = do { (subst, tvs') <- freshenTyVarBndrs tvs
+       ; return (FamInst { fi_fam      = tyConName fam_tc
                          , fi_flavor   = flavor
                          , fi_tcs      = roughMatchTcs lhs
                          , fi_tvs      = tvs'
                          , fi_tys      = substTys subst lhs
                          , fi_rhs      = substTy  subst rhs
                          , fi_axiom    = axiom }) }
-  where
-    fam_tc_name = tyConName fam_tc
-    CoAxBranch { cab_loc = loc
-               , cab_tvs = tvs
-               , cab_lhs = lhs
-               , cab_rhs = rhs } = branch
-
 \end{code}
 
 
index ea2ca0b..cc6f759 100644 (file)
@@ -15,6 +15,7 @@ module Inst (
 
        newOverloadedLit, mkOverLit,
 
+       newClsInst,
        tcGetInsts, tcGetInstEnvs, getOverlapFlag,
        tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
        tcSyntaxName,
@@ -44,6 +45,8 @@ import Type
 import Coercion ( Role(..) )
 import TcType
 import HscTypes
+import Class( Class )
+import MkId( mkDictFunId )
 import Id
 import Name
 import Var      ( EvVar, varType, setVarType )
@@ -383,18 +386,19 @@ syntaxNameCtxt name orig ty tidy_env
 %************************************************************************
 
 \begin{code}
-getOverlapFlag :: TcM OverlapFlag
-getOverlapFlag
+getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
+getOverlapFlag overlap_mode
   = do  { dflags <- getDynFlags
         ; let overlap_ok    = xopt Opt_OverlappingInstances dflags
               incoherent_ok = xopt Opt_IncoherentInstances  dflags
               use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
                                   , overlapMode   = x }
-              overlap_flag | incoherent_ok = use Incoherent
-                           | overlap_ok    = use Overlaps
-                           | otherwise     = use NoOverlap
+              default_oflag | incoherent_ok = use Incoherent
+                            | overlap_ok    = use Overlaps
+                            | otherwise     = use NoOverlap
 
-        ; return overlap_flag }
+              final_oflag = setOverlapModeMaybe default_oflag overlap_mode
+        ; return final_oflag }
 
 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 -- Gets both the external-package inst-env
@@ -406,6 +410,22 @@ tcGetInsts :: TcM [ClsInst]
 -- Gets the local class instances.
 tcGetInsts = fmap tcg_insts getGblEnv
 
+newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
+           -> Class -> [Type] -> TcM ClsInst
+newClsInst overlap_mode dfun_name tvs theta clas tys
+  = do { (subst, tvs') <- freshenTyVarBndrs tvs
+             -- Be sure to freshen those type variables,
+             -- so they are sure not to appear in any lookup
+       ; let tys'   = substTys subst tys
+             theta' = substTheta subst theta
+             dfun   = mkDictFunId dfun_name tvs' theta' clas tys'
+             -- Substituting in the DFun type just makes sure that
+             -- we are using TyVars rather than TcTyVars
+             -- Not sure if this is really the right place to do so,
+             -- but it'll do fine
+       ; oflag <- getOverlapFlag overlap_mode
+       ; return (mkLocalInstance dfun oflag tvs' clas tys') }
+
 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
   -- Add new locally-defined instances
 tcExtendLocalInstEnv dfuns thing_inside
index b39739d..53ca7f0 100644 (file)
@@ -39,12 +39,10 @@ import HscTypes
 import Avail
 
 import Unify( tcUnifyTy )
-import Id( idType )
 import Class
 import Type
 import Kind( isKind )
 import ErrUtils
-import MkId
 import DataCon
 import Maybes
 import RdrName
@@ -369,16 +367,15 @@ tcDeriving tycl_decls inst_decls deriv_decls
         -- Generic1 should use the same TcGenGenerics.MetaTyCons)
         ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs
 
-        ; overlap_flag <- getOverlapFlag
         ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
-        ; insts1 <- mapM (genInst True overlap_flag commonAuxs) given_specs
+        ; insts1 <- mapM (genInst commonAuxs) given_specs
 
         -- the stand-alone derived instances (@insts1@) are used when inferring
         -- the contexts for "deriving" clauses' instances (@infer_specs@)
         ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
-                         inferInstanceContexts overlap_flag infer_specs
+                         inferInstanceContexts infer_specs
 
-        ; insts2 <- mapM (genInst False overlap_flag commonAuxs) final_specs
+        ; insts2 <- mapM (genInst commonAuxs) final_specs
 
         ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
         ; loc <- getSrcSpanM
@@ -1704,11 +1701,11 @@ ordered by sorting on type varible, tv, (major key) and then class, k,
 \end{itemize}
 
 \begin{code}
-inferInstanceContexts :: OverlapFlag -> [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType]
+inferInstanceContexts :: [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType]
 
-inferInstanceContexts [] = return []
+inferInstanceContexts [] = return []
 
-inferInstanceContexts oflag infer_specs
+inferInstanceContexts infer_specs
   = do  { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
         ; iterate_deriv 1 initial_solutions }
   where
@@ -1734,7 +1731,7 @@ inferInstanceContexts oflag infer_specs
       | otherwise
       = do {      -- Extend the inst info from the explicit instance decls
                   -- with the current set of solutions, and simplify each RHS
-             inst_specs <- zipWithM (mkInstance oflag) current_solns infer_specs
+             inst_specs <- zipWithM newDerivClsInst current_solns infer_specs
            ; new_solns <- checkNoErrs $
                           extendLocalInstEnv inst_specs $
                           mapM gen_soln infer_specs
@@ -1767,15 +1764,10 @@ inferInstanceContexts oflag infer_specs
         the_pred = mkClassPred clas inst_tys
 
 ------------------------------------------------------------------
-mkInstance :: OverlapFlag -> ThetaType -> DerivSpec theta -> TcM ClsInst
-mkInstance overlap_flag theta
-           (DS { ds_name = dfun_name
-               , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
-  = do { (subst, tvs') <- tcInstSkolTyVars tvs
-       ; return (mkLocalInstance dfun overlap_flag tvs' clas (substTys subst tys)) }
-  where
-    dfun = mkDictFunId dfun_name tvs theta clas tys
-
+newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst
+newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode
+                          , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
+  = newClsInst overlap_mode dfun_name tvs theta clas tys
 
 extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
 -- Add new locally-defined instances; don't bother to check
@@ -1989,18 +1981,15 @@ the renamer.  What a great hack!
 -- Representation tycons differ from the tycon in the instance signature in
 -- case of instances for indexed families.
 --
-genInst :: Bool             -- True <=> standalone deriving
-        -> OverlapFlag
-        -> CommonAuxiliaries
-        -> DerivSpec ThetaType 
+genInst :: CommonAuxiliaries
+        -> DerivSpec ThetaType
         -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
-genInst _standalone_deriv default_oflag comauxs
+genInst comauxs
         spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
                  , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
-                 , ds_overlap = overlap_mode
                  , ds_name = dfun_name, ds_cls = clas, ds_loc = loc })
   | is_newtype   -- See Note [Bindings for Generalised Newtype Deriving]
-  = do { inst_spec <- mkInstance oflag theta spec
+  = do { inst_spec <- newDerivClsInst theta spec
        ; traceTc "genInst/is_newtype" (vcat [ppr loc, ppr clas, ppr tvs, ppr tys, ppr rhs_ty])
        ; return ( InstInfo
                     { iSpec   = inst_spec
@@ -2015,10 +2004,11 @@ genInst _standalone_deriv default_oflag comauxs
               -- See Note [Newtype deriving and unused constructors]
 
   | otherwise
-  = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas 
+  = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas
                                         dfun_name rep_tycon
                                         (lookup rep_tycon comauxs)
-       ; inst_spec <- mkInstance oflag theta spec
+       ; inst_spec <- newDerivClsInst theta spec
+       ; traceTc "newder" (ppr inst_spec)
        ; let inst_info = InstInfo { iSpec   = inst_spec
                                   , iBinds  = InstBindings
                                                 { ib_binds = meth_binds
@@ -2027,7 +2017,6 @@ genInst _standalone_deriv default_oflag comauxs
                                                 , ib_derived = True } }
        ; return ( inst_info, deriv_stuff, Nothing ) }
   where
-    oflag  = setOverlapModeMaybe default_oflag overlap_mode
     rhs_ty = newTyConInstRhs rep_tycon rep_tc_args
 
 genDerivStuff :: SrcSpan -> Class -> Name -> TyCon
index f135fe5..86a2c14 100644 (file)
@@ -538,15 +538,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
                 -- Dfun location is that of instance *header*
 
-        ; overlap_flag <-
-            do defaultOverlapFlag <- getOverlapFlag
-               return $ setOverlapModeMaybe defaultOverlapFlag overlap_mode
-        ; (subst, tyvars') <- tcInstSkolTyVars tyvars
-        ; let dfun      = mkDictFunId dfun_name tyvars theta clas inst_tys
-              ispec     = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys)
-                            -- Be sure to freshen those type variables,
-                            -- so they are sure not to appear in any lookup
-              inst_info = InstInfo { iSpec  = ispec
+        ; ispec <- newClsInst overlap_mode dfun_name tyvars theta clas inst_tys
+        ; let inst_info = InstInfo { iSpec  = ispec
                                    , iBinds = InstBindings
                                      { ib_binds = binds
                                      , ib_pragmas = uprags
index 2ba19a6..ed68690 100644 (file)
@@ -37,11 +37,13 @@ module TcMType (
   -- Instantiation
   tcInstTyVars, newSigTyVar,
   tcInstType,
-  tcInstSkolTyVars, tcInstSuperSkolTyVars,tcInstSuperSkolTyVarsX,
+  tcInstSkolTyVars, tcInstSuperSkolTyVarsX,
   tcInstSigTyVarsLoc, tcInstSigTyVars,
-  tcInstSkolTyVar, tcInstSkolType,
+  tcInstSkolType,
   tcSkolDFunType, tcSuperSkolTyVars,
 
+  instSkolTyVars, freshenTyVarBndrs,
+
   --------------------------------
   -- Zonking
   zonkTcPredType,
@@ -195,10 +197,9 @@ tcInstType inst_tyvars ty
                             ; return (tyvars', theta, tau) }
 
 tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType)
--- Instantiate a type signature with skolem constants, but
--- do *not* give them fresh names, because we want the name to
--- be in the type environment: it is lexically scoped.
-tcSkolDFunType ty = tcInstType (\tvs -> return (tcSuperSkolTyVars tvs)) ty
+-- Instantiate a type signature with skolem constants.
+-- We could give them fresh names, but no need to do so
+tcSkolDFunType ty = tcInstType tcInstSuperSkolTyVars ty
 
 tcSuperSkolTyVars :: [TyVar] -> (TvSubst, [TcTyVar])
 -- Make skolem constants, but do *not* give them new names, as above
@@ -214,73 +215,73 @@ tcSuperSkolTyVar subst tv
     kind   = substTy subst (tyVarKind tv)
     new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv
 
-tcInstSkolTyVar :: SrcSpan -> Bool -> TvSubst -> TyVar
-                -> TcRnIf gbl lcl (TvSubst, TcTyVar)
--- Instantiate the tyvar, using
---      * the occ-name and kind of the supplied tyvar,
---      * the unique from the monad,
---      * the location either from the tyvar (skol_info = SigSkol)
---                     or from the monad (otherwise)
-tcInstSkolTyVar loc overlappable subst tyvar
-  = do  { uniq <- newUnique
-        ; let new_name = mkInternalName uniq occ loc
-              new_tv   = mkTcTyVar new_name kind (SkolemTv overlappable)
-        ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
-  where
-    old_name = tyVarName tyvar
-    occ      = nameOccName old_name
-    kind     = substTy subst (tyVarKind tyvar)
-
--- Wrappers
--- we need to be able to do this from outside the TcM monad:
 tcInstSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar])
-tcInstSkolTyVars = tcInstSkolTyVarsX (mkTopTvSubst [])
+tcInstSkolTyVars = tcInstSkolTyVars' False emptyTvSubst
 
-tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar]
-tcInstSuperSkolTyVars = fmap snd . tcInstSkolTyVars' True  (mkTopTvSubst [])
+tcInstSuperSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar])
+tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTvSubst
 
-tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX
-  :: TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar])
-tcInstSkolTyVarsX      subst = tcInstSkolTyVars' False subst
-tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True  subst
+tcInstSuperSkolTyVarsX :: TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar])
+tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst
 
 tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar])
 -- Precondition: tyvars should be ordered (kind vars first)
 -- see Note [Kind substitution when instantiating]
 -- Get the location from the monad; this is a complete freshening operation
-tcInstSkolTyVars' isSuperSkol subst tvs
+tcInstSkolTyVars' overlappable subst tvs
   = do { loc <- getSrcSpanM
-       ; mapAccumLM (tcInstSkolTyVar loc isSuperSkol) subst tvs }
+       ; instSkolTyVarsX (mkTcSkolTyVar loc overlappable) subst tvs }
+
+mkTcSkolTyVar :: SrcSpan -> Bool -> Unique -> Name -> Kind -> TcTyVar
+mkTcSkolTyVar loc overlappable uniq old_name kind
+  = mkTcTyVar (mkInternalName uniq (getOccName old_name) loc)
+              kind
+              (SkolemTv overlappable)
 
 tcInstSigTyVarsLoc :: SrcSpan -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar])
 -- We specify the location
-tcInstSigTyVarsLoc loc = mapAccumLM (tcInstSkolTyVar loc False) (mkTopTvSubst [])
+tcInstSigTyVarsLoc loc = instSkolTyVars (mkTcSkolTyVar loc False)
 
 tcInstSigTyVars :: [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar])
 -- Get the location from the TyVar itself, not the monad
-tcInstSigTyVars = mapAccumLM inst_tv (mkTopTvSubst [])
+tcInstSigTyVars
+  = instSkolTyVars mk_tv
   where
-    inst_tv subst tv = tcInstSkolTyVar (getSrcSpan tv) False subst tv
+    mk_tv uniq old_name kind
+       = mkTcTyVar (setNameUnique old_name uniq) kind (SkolemTv False)
 
 tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type with fresh skolem constants
 -- Binding location comes from the monad
 tcInstSkolType ty = tcInstType tcInstSkolTyVars ty
 
-newSigTyVar :: Name -> Kind -> TcM TcTyVar
-newSigTyVar name kind
-  = do { uniq <- newUnique
-       ; let name' = setNameUnique name uniq
-                      -- Use the same OccName so that the tidy-er
-                      -- doesn't gratuitously rename 'a' to 'a0' etc
-       ; details <- newMetaDetails SigTv
-       ; return (mkTcTyVar name' kind details) }
+------------------
+freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar])
+-- ^ Give fresh uniques to a bunch of TyVars, but they stay
+--   as TyVars, rather than becoming TcTyVars
+-- Used in FamInst.newFamInst, and Inst.newClsInst
+freshenTyVarBndrs = instSkolTyVars mk_tv
+  where
+    mk_tv uniq old_name kind = mkTyVar (setNameUnique old_name uniq) kind
 
-newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
-newMetaDetails info
-  = do { ref <- newMutVar Flexi
-       ; untch <- getUntouchables
-       ; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_untch = untch }) }
+------------------
+instSkolTyVars :: (Unique -> Name -> Kind -> TyVar)
+                -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar])
+instSkolTyVars mk_tv = instSkolTyVarsX mk_tv emptyTvSubst
+
+instSkolTyVarsX :: (Unique -> Name -> Kind -> TyVar)
+                -> TvSubst -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar])
+instSkolTyVarsX mk_tv = mapAccumLM (instSkolTyVarX mk_tv)
+
+instSkolTyVarX :: (Unique -> Name -> Kind -> TyVar)
+               -> TvSubst -> TyVar -> TcRnIf gbl lcl (TvSubst, TyVar)
+instSkolTyVarX mk_tv subst tyvar
+  = do  { uniq <- newUnique
+        ; let new_tv = mk_tv uniq old_name kind
+        ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
+  where
+    old_name = tyVarName tyvar
+    kind     = substTy subst (tyVarKind tyvar)
 \end{code}
 
 Note [Kind substitution when instantiating]
@@ -318,6 +319,21 @@ newMetaTyVar meta_info kind
         ; details <- newMetaDetails meta_info
         ; return (mkTcTyVar name kind details) }
 
+newSigTyVar :: Name -> Kind -> TcM TcTyVar
+newSigTyVar name kind
+  = do { uniq <- newUnique
+       ; let name' = setNameUnique name uniq
+                      -- Use the same OccName so that the tidy-er
+                      -- doesn't gratuitously rename 'a' to 'a0' etc
+       ; details <- newMetaDetails SigTv
+       ; return (mkTcTyVar name' kind details) }
+
+newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
+newMetaDetails info
+  = do { ref <- newMutVar Flexi
+       ; untch <- getUntouchables
+       ; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_untch = untch }) }
+
 cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
 cloneMetaTyVar tv
   = ASSERT( isTcTyVar tv )