never executed always true always false
    1 {-# LANGUAGE BangPatterns #-}
    2 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
    3 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
    4 
    5 -- | Tidying types and coercions for printing in error messages.
    6 module GHC.Core.TyCo.Tidy
    7   (
    8         -- * Tidying type related things up for printing
    9         tidyType,      tidyTypes,
   10         tidyOpenType,  tidyOpenTypes,
   11         tidyOpenKind,
   12         tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes,
   13         tidyOpenTyCoVar, tidyOpenTyCoVars,
   14         tidyTyCoVarOcc,
   15         tidyTopType,
   16         tidyKind,
   17         tidyCo, tidyCos,
   18         tidyTyCoVarBinder, tidyTyCoVarBinders
   19   ) where
   20 
   21 import GHC.Prelude
   22 
   23 import GHC.Core.TyCo.Rep
   24 import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList)
   25 
   26 import GHC.Types.Name hiding (varName)
   27 import GHC.Types.Var
   28 import GHC.Types.Var.Env
   29 import GHC.Utils.Misc (strictMap)
   30 
   31 import Data.List (mapAccumL)
   32 
   33 {-
   34 %************************************************************************
   35 %*                                                                      *
   36 \subsection{TidyType}
   37 %*                                                                      *
   38 %************************************************************************
   39 -}
   40 
   41 -- | This tidies up a type for printing in an error message, or in
   42 -- an interface file.
   43 --
   44 -- It doesn't change the uniques at all, just the print names.
   45 tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
   46 tidyVarBndrs tidy_env tvs
   47   = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs
   48 
   49 tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
   50 tidyVarBndr tidy_env@(occ_env, subst) var
   51   = case tidyOccName occ_env (getHelpfulOccName var) of
   52       (occ_env', occ') -> ((occ_env', subst'), var')
   53         where
   54           subst' = extendVarEnv subst var var'
   55           var'   = updateVarType (tidyType tidy_env) (setVarName var name')
   56           name'  = tidyNameOcc name occ'
   57           name   = varName var
   58 
   59 avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv
   60 -- Seed the occ_env with clashes among the names, see
   61 -- Note [Tidying multiple names at once] in GHC.Types.Names.OccName
   62 avoidNameClashes tvs (occ_env, subst)
   63   = (avoidClashesOccEnv occ_env occs, subst)
   64   where
   65     occs = map getHelpfulOccName tvs
   66 
   67 getHelpfulOccName :: TyCoVar -> OccName
   68 -- A TcTyVar with a System Name is probably a
   69 -- unification variable; when we tidy them we give them a trailing
   70 -- "0" (or 1 etc) so that they don't take precedence for the
   71 -- un-modified name. Plus, indicating a unification variable in
   72 -- this way is a helpful clue for users
   73 getHelpfulOccName tv
   74   | isSystemName name, isTcTyVar tv
   75   = mkTyVarOcc (occNameString occ ++ "0")
   76   | otherwise
   77   = occ
   78   where
   79    name = varName tv
   80    occ  = getOccName name
   81 
   82 tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis
   83                   -> (TidyEnv, VarBndr TyCoVar vis)
   84 tidyTyCoVarBinder tidy_env (Bndr tv vis)
   85   = (tidy_env', Bndr tv' vis)
   86   where
   87     (tidy_env', tv') = tidyVarBndr tidy_env tv
   88 
   89 tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis]
   90                    -> (TidyEnv, [VarBndr TyCoVar vis])
   91 tidyTyCoVarBinders tidy_env tvbs
   92   = mapAccumL tidyTyCoVarBinder
   93               (avoidNameClashes (binderVars tvbs) tidy_env) tvbs
   94 
   95 ---------------
   96 tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv
   97 -- ^ Add the free 'TyVar's to the env in tidy form,
   98 -- so that we can tidy the type they are free in
   99 tidyFreeTyCoVars tidy_env tyvars
  100   = fst (tidyOpenTyCoVars tidy_env tyvars)
  101 
  102 ---------------
  103 tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
  104 tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars
  105 
  106 ---------------
  107 tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
  108 -- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name
  109 -- using the environment if one has not already been allocated. See
  110 -- also 'tidyVarBndr'
  111 tidyOpenTyCoVar env@(_, subst) tyvar
  112   = case lookupVarEnv subst tyvar of
  113         Just tyvar' -> (env, tyvar')              -- Already substituted
  114         Nothing     ->
  115           let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar))
  116           in tidyVarBndr env' tyvar  -- Treat it as a binder
  117 
  118 ---------------
  119 tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar
  120 tidyTyCoVarOcc env@(_, subst) tv
  121   = case lookupVarEnv subst tv of
  122         Nothing  -> updateVarType (tidyType env) tv
  123         Just tv' -> tv'
  124 
  125 ---------------
  126 
  127 {-
  128 Note [Strictness in tidyType and friends]
  129 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  130 
  131 Since the result of tidying will be inserted into the HPT, a potentially
  132 long-lived structure, we generally want to avoid pieces of the old AST
  133 being retained by the thunks produced by tidying.
  134 
  135 For this reason we take great care to ensure that all pieces of the tidied AST
  136 are evaluated strictly.  So you will see lots of strict applications ($!) and
  137 uses of `strictMap` in `tidyType`, `tidyTypes` and `tidyCo`.
  138 
  139 In the case of tidying of lists (e.g. lists of arguments) we prefer to use
  140 `strictMap f xs` rather than `seqList (map f xs)` as the latter will
  141 unnecessarily allocate a thunk, which will then be almost-immediately
  142 evaluated, for each list element.
  143 
  144 Making `tidyType` strict has a rather large effect on performance: see #14738.
  145 Sometimes as much as a 5% reduction in allocation.
  146 -}
  147 
  148 -- | Tidy a list of Types
  149 --
  150 -- See Note [Strictness in tidyType and friends]
  151 tidyTypes :: TidyEnv -> [Type] -> [Type]
  152 tidyTypes env tys = strictMap (tidyType env) tys
  153 
  154 ---------------
  155 
  156 
  157 -- | Tidy a Type
  158 --
  159 -- See Note [Strictness in tidyType and friends]
  160 tidyType :: TidyEnv -> Type -> Type
  161 tidyType _   t@(LitTy {})          = t -- Preserve sharing
  162 tidyType env (TyVarTy tv)          = TyVarTy $! tidyTyCoVarOcc env tv
  163 tidyType _   t@(TyConApp _ [])     = t -- Preserve sharing if possible
  164 tidyType env (TyConApp tycon tys)  = TyConApp tycon $! tidyTypes env tys
  165 tidyType env (AppTy fun arg)       = (AppTy $! (tidyType env fun)) $! (tidyType env arg)
  166 tidyType env ty@(FunTy _ w arg res)  = let { !w'   = tidyType env w
  167                                            ; !arg' = tidyType env arg
  168                                            ; !res' = tidyType env res }
  169                                        in ty { ft_mult = w', ft_arg = arg', ft_res = res' }
  170 tidyType env (ty@(ForAllTy{}))     = (mkForAllTys' $! (zip tvs' vis)) $! tidyType env' body_ty
  171   where
  172     (tvs, vis, body_ty) = splitForAllTyCoVars' ty
  173     (env', tvs') = tidyVarBndrs env tvs
  174 tidyType env (CastTy ty co)       = (CastTy $! tidyType env ty) $! (tidyCo env co)
  175 tidyType env (CoercionTy co)      = CoercionTy $! (tidyCo env co)
  176 
  177 
  178 -- The following two functions differ from mkForAllTys and splitForAllTyCoVars in that
  179 -- they expect/preserve the ArgFlag argument. These belong to "GHC.Core.Type", but
  180 -- how should they be named?
  181 mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type
  182 mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs
  183   where
  184     strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty
  185 
  186 splitForAllTyCoVars' :: Type -> ([TyCoVar], [ArgFlag], Type)
  187 splitForAllTyCoVars' ty = go ty [] []
  188   where
  189     go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)
  190     go ty                          tvs viss = (reverse tvs, reverse viss, ty)
  191 
  192 
  193 ---------------
  194 -- | Grabs the free type variables, tidies them
  195 -- and then uses 'tidyType' to work over the type itself
  196 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
  197 tidyOpenTypes env tys
  198   = (env', tidyTypes (trimmed_occ_env, var_env) tys)
  199   where
  200     (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $
  201                                 tyCoVarsOfTypesWellScoped tys
  202     trimmed_occ_env = initTidyOccEnv (map getOccName tvs')
  203       -- The idea here was that we restrict the new TidyEnv to the
  204       -- _free_ vars of the types, so that we don't gratuitously rename
  205       -- the _bound_ variables of the types.
  206 
  207 ---------------
  208 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
  209 tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in
  210                       (env', ty')
  211 
  212 ---------------
  213 -- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)
  214 tidyTopType :: Type -> Type
  215 tidyTopType ty = tidyType emptyTidyEnv ty
  216 
  217 ---------------
  218 tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
  219 tidyOpenKind = tidyOpenType
  220 
  221 tidyKind :: TidyEnv -> Kind -> Kind
  222 tidyKind = tidyType
  223 
  224 ----------------
  225 
  226 -- | Tidy a Coercion
  227 --
  228 -- See Note [Strictness in tidyType and friends]
  229 tidyCo :: TidyEnv -> Coercion -> Coercion
  230 tidyCo env@(_, subst) co
  231   = go co
  232   where
  233     go_mco MRefl    = MRefl
  234     go_mco (MCo co) = MCo $! go co
  235 
  236     go (Refl ty)             = Refl $! tidyType env ty
  237     go (GRefl r ty mco)      = (GRefl r $! tidyType env ty) $! go_mco mco
  238     go (TyConAppCo r tc cos) = TyConAppCo r tc $! strictMap go cos
  239     go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2
  240     go (ForAllCo tv h co)    = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co)
  241                                where (envp, tvp) = tidyVarBndr env tv
  242             -- the case above duplicates a bit of work in tidying h and the kind
  243             -- of tv. But the alternative is to use coercionKind, which seems worse.
  244     go (FunCo r w co1 co2)   = ((FunCo r $! go w) $! go co1) $! go co2
  245     go (CoVarCo cv)          = case lookupVarEnv subst cv of
  246                                  Nothing  -> CoVarCo cv
  247                                  Just cv' -> CoVarCo cv'
  248     go (HoleCo h)            = HoleCo h
  249     go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! strictMap go cos
  250     go (UnivCo p r t1 t2)    = (((UnivCo $! (go_prov p)) $! r) $!
  251                                 tidyType env t1) $! tidyType env t2
  252     go (SymCo co)            = SymCo $! go co
  253     go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2
  254     go (NthCo r d co)        = NthCo r d $! go co
  255     go (LRCo lr co)          = LRCo lr $! go co
  256     go (InstCo co ty)        = (InstCo $! go co) $! go ty
  257     go (KindCo co)           = KindCo $! go co
  258     go (SubCo co)            = SubCo $! go co
  259     go (AxiomRuleCo ax cos)  = AxiomRuleCo ax $ strictMap go cos
  260 
  261     go_prov (PhantomProv co)    = PhantomProv $! go co
  262     go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co
  263     go_prov p@(PluginProv _)    = p
  264     go_prov p@(CorePrepProv _)  = p
  265 
  266 tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
  267 tidyCos env = strictMap (tidyCo env)