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         newTyConRhs
  19     ) where
  20
  21 #include "HsVersions.h"
  22
  23 import TypeRep          ( Type(..), TyNote(..), PredType(..) )  -- friend
  24 import HsSyn            ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
  25 import RnHsSyn          ( extractHsTyNames )
  26 import Type             ( predTypeRep )
  27 import BuildTyCl        ( newTyConRhs )
  28 import HscTypes         ( TyThing(..) )
  29 import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
  30                           getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
  31                           tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs )
  32 import Class            ( classTyCon )
  33 import DataCon          ( dataConRepArgTys, dataConOrigArgTys )
  34 import Var              ( TyVar )
  35 import VarSet
  36 import Name             ( Name, isTyVarName )
  37 import NameEnv
  38 import NameSet
  39 import Digraph          ( SCC(..), stronglyConnComp, stronglyConnCompR )
  40 import BasicTypes       ( RecFlag(..) )
  41 import SrcLoc           ( Located(..), unLoc )
  42 import Outputable
  43 \end{code}
  44
  45
  46 %************************************************************************
  47 %*                                                                      *
  48         Cycles in class and type synonym declarations
  49 %*                                                                      *
  50 %************************************************************************
  51
  52 We check for type synonym and class cycles on the *source* code.
  53 Main reasons:
  54
  55   a) Otherwise we'd need a special function to extract type-synonym tycons
  56         from a type, whereas we have extractHsTyNames already
  57
  58   b) If we checked for type synonym loops after building the TyCon, we
  59         can't do a hoistForAllTys on the type synonym rhs, (else we fall into
  60         a black hole) which seems unclean.  Apart from anything else, it'd mean
  61         that a type-synonym rhs could have for-alls to the right of an arrow,
  62         which means adding new cases to the validity checker
  63
  64         Indeed, in general, checking for cycles beforehand means we need to
  65         be less careful about black holes through synonym cycles.
  66
  67 The main disadvantage is that a cycle that goes via a type synonym in an
  68 .hi-boot file can lead the compiler into a loop, because it assumes that cycles
  69 only occur in source code.  But hi-boot files are trusted anyway, so this isn't
  70 much worse than (say) a kind error.
  71
  72 [  NOTE ----------------------------------------------
  73 If we reverse this decision, this comment came from tcTyDecl1, and should
  74  go back there
  75         -- dsHsType, not tcHsKindedType, to avoid a loop.  tcHsKindedType does hoisting,
  76         -- which requires looking through synonyms... and therefore goes into a loop
  77         -- on (erroneously) recursive synonyms.
  78         -- Solution: do not hoist synonyms, because they'll be hoisted soon enough
  79         --           when they are substituted
  80
  81 We'd also need to add back in this definition
  82
  83 synTyConsOfType :: Type -> [TyCon]
  84 -- Does not look through type synonyms at all
  85 -- Return a list of synonym tycons
  86 synTyConsOfType ty
  87   = nameEnvElts (go ty)
  88   where
  89      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
  90      go (TyVarTy v)               = emptyNameEnv
  91      go (TyConApp tc tys)         = go_tc tc tys        -- See note (a)
  92      go (NewTcApp tc tys)         = go_s tys    -- Ignore tycon
  93      go (AppTy a b)               = go a `plusNameEnv` go b
  94      go (FunTy a b)               = go a `plusNameEnv` go b
  95      go (PredTy (IParam _ ty))    = go ty
  96      go (PredTy (ClassP cls tys)) = go_s tys    -- Ignore class
  97      go (NoteTy (SynNote ty) _)   = go ty       -- Don't look through it!
  98      go (NoteTy other ty)         = go ty
  99      go (ForAllTy _ ty)           = go ty
 100
 101         -- Note (a): the unexpanded branch of a SynNote has a
 102         --           TyConApp for the synonym, so the tc of
 103         --           a TyConApp must be tested for possible synonyms
 104
 105      go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc
 106                   | otherwise     = go_s tys
 107      go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
 108 ---------------------------------------- END NOTE ]
 109
 110 \begin{code}
 111 calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
 112 calcSynCycles decls
 113   = stronglyConnComp syn_edges
 114   where
 115     syn_edges = [ (ldecl, unLoc (tcdLName decl),
 116                           mk_syn_edges (tcdSynRhs decl))
 117                 | ldecl@(L _ decl) <- decls ]
 118
 119     mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs),
 120                               not (isTyVarName tc) ]
 121
 122
 123 calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
 124 calcClassCycles decls
 125   = [decls | CyclicSCC decls <- stronglyConnComp cls_edges]
 126   where
 127     cls_edges = [ (ldecl, unLoc (tcdLName decl),
 128                           mk_cls_edges (unLoc (tcdCtxt decl)))
 129                 | ldecl@(L _ decl) <- decls, isClassDecl decl ]
 130
 131     mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
 132 \end{code}
 133
 134
 135 %************************************************************************
 136 %*                                                                      *
 137         Deciding which type constructors are recursive
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 A newtype M.T is defined to be "recursive" iff
 142         (a) its rhs mentions an abstract (hi-boot) TyCon
 143    or   (b) one can get from T's rhs to T via type
 144             synonyms, or non-recursive newtypes *in M*
 145  e.g.  newtype T = MkT (T -> Int)
 146
 147 (a)     is conservative; it assumes that the hi-boot type can loop
 148         around to T.  That's why in (b) we can restrict attention
 149         to tycons in M, because any loops through newtypes outside M
 150         will be broken by those newtypes
 151
 152 An algebraic data type M.T is "recursive" iff
 153         it has just one constructor, and
 154         (a) its arg types mention an abstract (hi-boot) TyCon
 155  or     (b) one can get from its arg types to T via type synonyms,
 156             or by non-recursive newtypes or non-recursive product types in M
 157  e.g.  data T = MkT (T -> Int) Bool
 158
 159 A type synonym is recursive if one can get from its
 160 right hand side back to it via type synonyms.  (This is
 161 reported as an error.)
 162
 163 A class is recursive if one can get from its superclasses
 164 back to it.  (This is an error too.)
 165
 166 Hi-boot types
 167 ~~~~~~~~~~~~~
 168 A data type read from an hi-boot file will have an Unknown in its data constructors,
 169 and will respond True to isHiBootTyCon. The idea is that we treat these as if one
 170 could get from these types to anywhere.  So when we see
 171
 172         module Baz where
 173         import {-# SOURCE #-} Foo( T )
 174         newtype S = MkS T
 175
 176 then we mark S as recursive, just in case. What that means is that if we see
 177
 178         import Baz( S )
 179         newtype R = MkR S
 180
 181 then we don't need to look inside S to compute R's recursiveness.  Since S is imported
 182 (not from an hi-boot file), one cannot get from R back to S except via an hi-boot file,
 183 and that means that some data type will be marked recursive along the way.  So R is
 184 unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary)
 185
 186 This in turn means that we grovel through fewer interface files when computing
 187 recursiveness, because we need only look at the type decls in the module being
 188 compiled, plus the outer structure of directly-mentioned types.
 189
 190 \begin{code}
 191 calcRecFlags :: [TyThing] -> (Name -> RecFlag)
 192 calcRecFlags tyclss
 193   = is_rec
 194   where
 195     is_rec n | n `elemNameSet` rec_names = Recursive
 196              | otherwise                 = NonRecursive
 197
 198     rec_names = nt_loop_breakers `unionNameSets` prod_loop_breakers
 199
 200     all_tycons = map getTyCon tyclss    -- Recursion of newtypes/data types
 201                                         -- can happen via the class TyCon
 202
 203         -------------------------------------------------
 204         --                      NOTE
 205         -- These edge-construction loops rely on
 206         -- every loop going via tyclss, the types and classes
 207         -- in the module being compiled.  Stuff in interface
 208         -- files should be correctly marked.  If not (e.g. a
 209         -- type synonym in a hi-boot file) we can get an infinite
 210         -- loop.  We could program round this, but it'd make the code
 211         -- rather less nice, so I'm not going to do that yet.
 212
 213         --------------- Newtypes ----------------------
 214     new_tycons = filter isNewTyCon all_tycons
 215     nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
 216     is_rec_nt tc = tyConName tc  `elemNameSet` nt_loop_breakers
 217         -- is_rec_nt is a locally-used helper function
 218
 219     nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
 220
 221     mk_nt_edges nt      -- Invariant: nt is a newtype
 222         = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt))
 223                         -- tyConsOfType looks through synonyms
 224
 225     mk_nt_edges1 nt tc
 226         | tc `elem` new_tycons = [tc]           -- Loop
 227         | isHiBootTyCon tc     = [nt]           -- Make it self-recursive if
 228                                                 -- it mentions an hi-boot TyCon
 229                 -- At this point we know that either it's a local data type,
 230                 -- or it's imported.  Either way, it can't form part of a cycle
 231         | otherwise = []
 232
 233         --------------- Product types ----------------------
 234         -- The "prod_tycons" are the non-newtype products
 235     prod_tycons = [tc | tc <- all_tycons,
 236                         not (isNewTyCon tc), isProductTyCon tc]
 237     prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
 238
 239     prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
 240
 241     mk_prod_edges tc    -- Invariant: tc is a product tycon
 242         = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
 243
 244     mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty)
 245
 246     mk_prod_edges2 ptc tc
 247         | tc `elem` prod_tycons   = [tc]                -- Local product
 248         | tc `elem` new_tycons    = if is_rec_nt tc     -- Local newtype
 249                                     then []
 250                                     else mk_prod_edges1 ptc (newTyConRhs tc)
 251         | isHiBootTyCon tc        = [ptc]       -- Make it self-recursive if
 252                                                 -- it mentions an hi-boot TyCon
 253                 -- At this point we know that either it's a local non-product data type,
 254                 -- or it's imported.  Either way, it can't form part of a cycle
 255         | otherwise = []
 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 dataConRepArgTys 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}