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