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