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