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