ghc/compiler/typecheck/TcTyDecls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
   3 %
   4
   5 Analysis functions over data types.  Specficially
   6         a) detecting recursive types
   7         b) computing argument variances
   8
   9 This stuff is only used for source-code decls; it's recorded in interface
  10 files for imported data types.
  11
  12
  13 \begin{code}
  14 module TcTyDecls(
  15         calcTyConArgVrcs,
  16         calcRecFlags,
  17         calcClassCycles, calcSynCycles
  18     ) where
  19
  20 #include "HsVersions.h"
  21
  22 import TypeRep          ( Type(..), TyNote(..), PredType(..) )  -- friend
  23 import HsSyn            ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
  24 import RnHsSyn          ( extractHsTyNames )
  25 import Type             ( predTypeRep )
  26 import HscTypes         ( TyThing(..) )
  27 import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
  28                           getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
  29                           tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
  30 import Class            ( classTyCon )
  31 import DataCon          ( dataConOrigArgTys )
  32 import Var              ( TyVar )
  33 import VarSet
  34 import Name             ( Name, isTyVarName )
  35 import NameEnv
  36 import NameSet
  37 import Digraph          ( SCC(..), stronglyConnComp, stronglyConnCompR )
  38 import BasicTypes       ( RecFlag(..) )
  39 import SrcLoc           ( Located(..), unLoc )
  40 import Outputable
  41 \end{code}
  42
  43
  44 %************************************************************************
  45 %*                                                                      *
  46         Cycles in class and type synonym declarations
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 We check for type synonym and class cycles on the *source* code.
  51 Main reasons:
  52
  53   a) Otherwise we'd need a special function to extract type-synonym tycons
  54         from a type, whereas we have extractHsTyNames already
  55
  56   b) If we checked for type synonym loops after building the TyCon, we
  57         can't do a hoistForAllTys on the type synonym rhs, (else we fall into
  58         a black hole) which seems unclean.  Apart from anything else, it'd mean
  59         that a type-synonym rhs could have for-alls to the right of an arrow,
  60         which means adding new cases to the validity checker
  61
  62         Indeed, in general, checking for cycles beforehand means we need to
  63         be less careful about black holes through synonym cycles.
  64
  65 The main disadvantage is that a cycle that goes via a type synonym in an
  66 .hi-boot file can lead the compiler into a loop, because it assumes that cycles
  67 only occur in source code.  But hi-boot files are trusted anyway, so this isn't
  68 much worse than (say) a kind error.
  69
  70 [  NOTE ----------------------------------------------
  71 If we reverse this decision, this comment came from tcTyDecl1, and should
  72  go back there
  73         -- dsHsType, not tcHsKindedType, to avoid a loop.  tcHsKindedType does hoisting,
  74         -- which requires looking through synonyms... and therefore goes into a loop
  75         -- on (erroneously) recursive synonyms.
  76         -- Solution: do not hoist synonyms, because they'll be hoisted soon enough
  77         --           when they are substituted
  78
  79 We'd also need to add back in this definition
  80
  81 synTyConsOfType :: Type -> [TyCon]
  82 -- Does not look through type synonyms at all
  83 -- Return a list of synonym tycons
  84 synTyConsOfType ty
  85   = nameEnvElts (go ty)
  86   where
  87      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
  88      go (TyVarTy v)               = emptyNameEnv
  89      go (TyConApp tc tys)         = go_tc tc tys        -- See note (a)
  90      go (NewTcApp tc tys)         = go_s tys    -- Ignore tycon
  91      go (AppTy a b)               = go a `plusNameEnv` go b
  92      go (FunTy a b)               = go a `plusNameEnv` go b
  93      go (PredTy (IParam _ ty))    = go ty
  94      go (PredTy (ClassP cls tys)) = go_s tys    -- Ignore class
  95      go (NoteTy (SynNote ty) _)   = go ty       -- Don't look through it!
  96      go (NoteTy other ty)         = go ty
  97      go (ForAllTy _ ty)           = go ty
  98
  99         -- Note (a): the unexpanded branch of a SynNote has a
 100         --           TyConApp for the synonym, so the tc of
 101         --           a TyConApp must be tested for possible synonyms
 102
 103      go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc
 104                   | otherwise     = go_s tys
 105      go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
 106 ---------------------------------------- END NOTE ]
 107
 108 \begin{code}
 109 calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
 110 calcSynCycles decls
 111   = stronglyConnComp syn_edges
 112   where
 113     syn_edges = [ (ldecl, unLoc (tcdLName decl),
 114                           mk_syn_edges (tcdSynRhs decl))
 115                 | ldecl@(L _ decl) <- decls ]
 116
 117     mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs),
 118                               not (isTyVarName tc) ]
 119
 120
 121 calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
 122 calcClassCycles decls
 123   = [decls | CyclicSCC decls <- stronglyConnComp cls_edges]
 124   where
 125     cls_edges = [ (ldecl, unLoc (tcdLName decl),
 126                           mk_cls_edges (unLoc (tcdCtxt decl)))
 127                 | ldecl@(L _ decl) <- decls, isClassDecl decl ]
 128
 129     mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
 130 \end{code}
 131
 132
 133 %************************************************************************
 134 %*                                                                      *
 135         Deciding which type constructors are recursive
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 A newtype M.T is defined to be "recursive" iff
 140         (a) its rhs mentions an abstract (hi-boot) TyCon
 141    or   (b) one can get from T's rhs to T via type
 142             synonyms, or non-recursive newtypes *in M*
 143  e.g.  newtype T = MkT (T -> Int)
 144
 145 (a)     is conservative; it assumes that the hi-boot type can loop
 146         around to T.  That's why in (b) we can restrict attention
 147         to tycons in M, because any loops through newtypes outside M
 148         will be broken by those newtypes
 149
 150 An algebraic data type M.T is "recursive" iff
 151         it has just one constructor, and
 152         (a) its arg types mention an abstract (hi-boot) TyCon
 153  or     (b) one can get from its arg types to T via type synonyms,
 154             or by non-recursive newtypes or non-recursive product types in M
 155  e.g.  data T = MkT (T -> Int) Bool
 156
 157 A type synonym is recursive if one can get from its
 158 right hand side back to it via type synonyms.  (This is
 159 reported as an error.)
 160
 161 A class is recursive if one can get from its superclasses
 162 back to it.  (This is an error too.)
 163
 164 Hi-boot types
 165 ~~~~~~~~~~~~~
 166 A data type read from an hi-boot file will have an Unknown in its data constructors,
 167 and will respond True to isHiBootTyCon. The idea is that we treat these as if one
 168 could get from these types to anywhere.  So when we see
 169
 170         module Baz where
 171         import {-# SOURCE #-} Foo( T )
 172         newtype S = MkS T
 173
 174 then we mark S as recursive, just in case. What that means is that if we see
 175
 176         import Baz( S )
 177         newtype R = MkR S
 178
 179 then we don't need to look inside S to compute R's recursiveness.  Since S is imported
 180 (not from an hi-boot file), one cannot get from R back to S except via an hi-boot file,
 181 and that means that some data type will be marked recursive along the way.  So R is
 182 unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary)
 183
 184 This in turn means that we grovel through fewer interface files when computing
 185 recursiveness, because we need only look at the type decls in the module being
 186 compiled, plus the outer structure of directly-mentioned types.
 187
 188 \begin{code}
 189 calcRecFlags :: [TyThing] -> (Name -> RecFlag)
 190 calcRecFlags tyclss
 191   = is_rec
 192   where
 193     is_rec n | n `elemNameSet` rec_names = Recursive
 194              | otherwise                 = NonRecursive
 195
 196     rec_names = nt_loop_breakers `unionNameSets` prod_loop_breakers
 197
 198     all_tycons = map getTyCon tyclss    -- Recursion of newtypes/data types
 199                                         -- can happen via the class TyCon
 200
 201         -------------------------------------------------
 202         --                      NOTE
 203         -- These edge-construction loops rely on
 204         -- every loop going via tyclss, the types and classes
 205         -- in the module being compiled.  Stuff in interface
 206         -- files should be correctly marked.  If not (e.g. a
 207         -- type synonym in a hi-boot file) we can get an infinite
 208         -- loop.  We could program round this, but it'd make the code
 209         -- rather less nice, so I'm not going to do that yet.
 210
 211         --------------- Newtypes ----------------------
 212     new_tycons = filter isNewTyCon all_tycons
 213     nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
 214     is_rec_nt tc = tyConName tc  `elemNameSet` nt_loop_breakers
 215         -- is_rec_nt is a locally-used helper function
 216
 217     nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
 218
 219     mk_nt_edges nt      -- Invariant: nt is a newtype
 220         = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
 221                         -- tyConsOfType looks through synonyms
 222
 223     mk_nt_edges1 nt tc
 224         | tc `elem` new_tycons = [tc]           -- Loop
 225         | isHiBootTyCon tc     = [nt]           -- Make it self-recursive if
 226                                                 -- it mentions an hi-boot TyCon
 227                 -- At this point we know that either it's a local data type,
 228                 -- or it's imported.  Either way, it can't form part of a cycle
 229         | otherwise = []
 230
 231         --------------- Product types ----------------------
 232         -- The "prod_tycons" are the non-newtype products
 233     prod_tycons = [tc | tc <- all_tycons,
 234                         not (isNewTyCon tc), isProductTyCon tc]
 235     prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
 236
 237     prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
 238
 239     mk_prod_edges tc    -- Invariant: tc is a product tycon
 240         = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
 241
 242     mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty)
 243
 244     mk_prod_edges2 ptc tc
 245         | tc `elem` prod_tycons   = [tc]                -- Local product
 246         | tc `elem` new_tycons    = if is_rec_nt tc     -- Local newtype
 247                                     then []
 248                                     else mk_prod_edges1 ptc (new_tc_rhs tc)
 249         | isHiBootTyCon tc        = [ptc]       -- Make it self-recursive if
 250                                                 -- it mentions an hi-boot TyCon
 251                 -- At this point we know that either it's a local non-product data type,
 252                 -- or it's imported.  Either way, it can't form part of a cycle
 253         | otherwise = []
 254
 255 new_tc_rhs tc = snd (newTyConRhs tc)    -- Ignore the type variables
 256
 257 getTyCon (ATyCon tc) = tc
 258 getTyCon (AClass cl) = classTyCon cl
 259
 260 findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
 261 -- Finds a set of tycons that cut all loops
 262 findLoopBreakers deps
 263   = go [(tc,tc,ds) | (tc,ds) <- deps]
 264   where
 265     go edges = [ name
 266                | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
 267                  name <- tyConName tc : go edges']
 268 \end{code}
 269
 270 These two functions know about type representations, so they could be
 271 in Type or TcType -- but they are very specialised to this module, so
 272 I've chosen to put them here.
 273
 274 \begin{code}
 275 tcTyConsOfType :: Type -> [TyCon]
 276 -- tcTyConsOfType looks through all synonyms, but not through any newtypes.
 277 -- When it finds a Class, it returns the class TyCon.  The reaons it's here
 278 -- (not in Type.lhs) is because it is newtype-aware.
 279 tcTyConsOfType ty
 280   = nameEnvElts (go ty)
 281   where
 282      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
 283      go (TyVarTy v)               = emptyNameEnv
 284      go (TyConApp tc tys)         = go_tc tc tys
 285      go (NewTcApp tc tys)         = go_tc tc tys
 286      go (AppTy a b)               = go a `plusNameEnv` go b
 287      go (FunTy a b)               = go a `plusNameEnv` go b
 288      go (PredTy (IParam _ ty))    = go ty
 289      go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
 290      go (NoteTy _ ty)             = go ty
 291      go (ForAllTy _ ty)           = go ty
 292
 293      go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
 294      go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
 295 \end{code}
 296
 297
 298 %************************************************************************
 299 %*                                                                      *
 300         Compuing TyCon argument variances
 301 %*                                                                      *
 302 %************************************************************************
 303
 304 Computing the tyConArgVrcs info
 305 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 306
 307 @tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
 308 tyvar.  For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
 309 separately.  Note that this is information about occurrences of type
 310 variables, not usages of term variables.
 311
 312 The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
 313 syntycons only* such that all tycons referred to (by mutual recursion)
 314 appear in the list.  The fixpointing will be done on this set of
 315 tycons as a whole.  It returns a list of @tyconVrcInfo@ data, ready to
 316 be (knot-tyingly?) stuck back into the appropriate fields.
 317
 318 \begin{code}
 319 calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs
 320 -- Gives arg variances for TyCons,
 321 -- including the class TyCon of a class
 322 calcTyConArgVrcs tyclss
 323   = get_vrc
 324   where
 325     tycons = map getTyCon tyclss
 326
 327         -- We should only look up things that are in the map
 328     get_vrc n = case lookupNameEnv final_oi n of
 329                   Just (_, pms) -> pms
 330                   Nothing -> pprPanic "calcVrcs" (ppr n)
 331
 332         -- We are going to fold over this map,
 333         -- so we need the TyCon in the range
 334     final_oi :: NameEnv (TyCon, ArgVrcs)
 335     final_oi = tcaoFix initial_oi
 336
 337     initial_oi :: NameEnv (TyCon, ArgVrcs)
 338     initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc))
 339                            | tc <- tycons]
 340     initial tc = replicate (tyConArity tc) (False,False)
 341
 342     tcaoFix :: NameEnv (TyCon, ArgVrcs)   -- initial ArgVrcs per tycon
 343             -> NameEnv (TyCon, ArgVrcs)   -- fixpointed ArgVrcs per tycon
 344     tcaoFix oi
 345         | changed   = tcaoFix oi'
 346         | otherwise = oi'
 347         where
 348          (changed,oi') = foldNameEnv iterate (False,oi) oi
 349
 350     iterate (tc, pms) (changed,oi')
 351       = (changed || (pms /= pms'),
 352          extendNameEnv oi' (tyConName tc) (tc, pms'))
 353       where
 354         pms' = tcaoIter oi' tc  -- seq not simult
 355
 356     tcaoIter :: NameEnv (TyCon, ArgVrcs)  -- reference ArgVrcs (initial)
 357              -> TyCon                     -- tycon to update
 358              -> ArgVrcs                   -- new ArgVrcs for tycon
 359
 360     tcaoIter oi tc | isAlgTyCon tc
 361       = map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs
 362       where
 363         data_cons = tyConDataCons tc
 364         vs        = tyConTyVars tc
 365         argtys    = concatMap dataConOrigArgTys data_cons       -- Rep? or Orig?
 366
 367     tcaoIter oi tc | isSynTyCon tc
 368       = let (tyvs,ty) = getSynTyConDefn tc
 369                         -- we use the already-computed result for tycons not in this SCC
 370         in  map (\v -> vrcInTy (lookup oi) v ty) tyvs
 371
 372     lookup oi tc = case lookupNameEnv oi (tyConName tc) of
 373                         Just (_, pms) -> pms
 374                         Nothing       -> tyConArgVrcs tc
 375          -- We use the already-computed result for tycons not in this SCC
 376 \end{code}
 377
 378
 379 Variance of tyvars in a type
 380 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 381
 382 A general variance-check function.  We pass a function for determining
 383 the @ArgVrc@s of a tycon; when fixpointing this refers to the current
 384 value; otherwise this should be looked up from the tycon's own
 385 tyConArgVrcs.  Again, it knows the representation of Types.
 386
 387 \begin{code}
 388 vrcInTy :: (TyCon -> ArgVrcs)  -- function to get argVrcs of a tycon (break out of recursion)
 389         -> TyVar               -- tyvar to check Vrcs of
 390         -> Type                -- type to check for occ in
 391         -> (Bool,Bool)         -- (occurs positively, occurs negatively)
 392
 393 vrcInTy fao v (NoteTy (SynNote _)   ty) = vrcInTy fao v ty
 394                         -- SynTyCon doesn't neccessarily have vrcInfo at this point,
 395                         -- so don't try and use it
 396
 397 vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
 398                                           then vrcInTy fao v ty
 399                                           else (False,False)
 400                         -- note that ftv cannot be calculated as occPos||occNeg,
 401                         -- since if a tyvar occurs only as unused tyconarg,
 402                         -- occPos==occNeg==False, but ftv=True
 403
 404 vrcInTy fao v (TyVarTy v')              = if v==v'
 405                                           then (True,False)
 406                                           else (False,False)
 407
 408 vrcInTy fao v (AppTy ty1 ty2)           = if vrcInTy fao v ty2 /= (False,False)
 409                                           then (True,True)
 410                                           else vrcInTy fao v ty1
 411                         -- ty1 is probably unknown (or it would have been beta-reduced);
 412                         -- hence if v occurs in ty2 at all then it could occur with
 413                         -- either variance.  Otherwise it occurs as it does in ty1.
 414
 415 vrcInTy fao v (FunTy ty1 ty2)           = negVrc (vrcInTy fao v ty1)
 416                                           `orVrc`
 417                                           vrcInTy fao v ty2
 418
 419 vrcInTy fao v (ForAllTy v' ty)          = if v==v'
 420                                           then (False,False)
 421                                           else vrcInTy fao v ty
 422
 423 vrcInTy fao v (TyConApp tc tys)         = let pms1 = map (vrcInTy fao v) tys
 424                                               pms2 = fao tc
 425                                           in  orVrcs (zipWith timesVrc pms1 pms2)
 426
 427 vrcInTy fao v (NewTcApp tc tys)         = let pms1 = map (vrcInTy fao v) tys
 428                                               pms2 = fao tc
 429                                           in  orVrcs (zipWith timesVrc pms1 pms2)
 430
 431 vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st)
 432 \end{code}
 433
 434 Variance algebra
 435 ~~~~~~~~~~~~~~~~
 436
 437 \begin{code}
 438 orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
 439 orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
 440
 441 orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
 442 orVrcs = foldl orVrc (False,False)
 443
 444 negVrc :: (Bool,Bool) -> (Bool,Bool)
 445 negVrc (p1,m1) = (m1,p1)
 446
 447 anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
 448 anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
 449                     (False,False) as
 450
 451 timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
 452 timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
 453                             p1 && m2 || m1 && p2)
 454 \end{code}