compiler/typecheck/TcTyDecls.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
   4 %
   5
   6 Analysis functions over data types.  Specficially, detecting recursive types.
   7
   8 This stuff is only used for source-code decls; it's recorded in interface
   9 files for imported data types.
  10
  11 \begin{code}
  12 module TcTyDecls(
  13         calcRecFlags,
  14         calcClassCycles, calcSynCycles
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import TypeRep
  20 import HsSyn
  21 import RnHsSyn
  22 import Type
  23 import HscTypes
  24 import TyCon
  25 import Class
  26 import DataCon
  27 import Var
  28 import VarSet
  29 import Name
  30 import NameEnv
  31 import NameSet
  32 import Digraph
  33 import BasicTypes
  34 import SrcLoc
  35 import Outputable
  36 \end{code}
  37
  38
  39 %************************************************************************
  40 %*                                                                      *
  41         Cycles in class and type synonym declarations
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 Checking for class-decl loops is easy, because we don't allow class decls
  46 in interface files.
  47
  48 We allow type synonyms in hi-boot files, but we *trust* hi-boot files,
  49 so we don't check for loops that involve them.  So we only look for synonym
  50 loops in the module being compiled.
  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 entirely within the source code of the module being compiled.
  70 But hi-boot files are trusted anyway, so this isn't much worse than (say)
  71 a kind error.
  72
  73 [  NOTE ----------------------------------------------
  74 If we reverse this decision, this comment came from tcTyDecl1, and should
  75  go back there
  76         -- dsHsType, not tcHsKindedType, to avoid a loop.  tcHsKindedType does hoisting,
  77         -- which requires looking through synonyms... and therefore goes into a loop
  78         -- on (erroneously) recursive synonyms.
  79         -- Solution: do not hoist synonyms, because they'll be hoisted soon enough
  80         --           when they are substituted
  81
  82 We'd also need to add back in this definition
  83
  84 synTyConsOfType :: Type -> [TyCon]
  85 -- Does not look through type synonyms at all
  86 -- Return a list of synonym tycons
  87 synTyConsOfType ty
  88   = nameEnvElts (go ty)
  89   where
  90      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
  91      go (TyVarTy v)               = emptyNameEnv
  92      go (TyConApp tc tys)         = go_tc tc tys
  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 _ ty)             = go ty
  98      go (ForAllTy _ ty)           = go ty
  99
 100      go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc
 101                   | otherwise     = go_s tys
 102      go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
 103 ---------------------------------------- END NOTE ]
 104
 105 \begin{code}
 106 calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
 107 calcSynCycles decls
 108   = stronglyConnComp syn_edges
 109   where
 110     syn_edges = [ (ldecl, unLoc (tcdLName decl),
 111                           mk_syn_edges (tcdSynRhs decl))
 112                 | ldecl@(L _ decl) <- decls ]
 113
 114     mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs),
 115                               not (isTyVarName tc) ]
 116
 117
 118 calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
 119 calcClassCycles decls
 120   = [decls | CyclicSCC decls <- stronglyConnComp cls_edges]
 121   where
 122     cls_edges = [ (ldecl, unLoc (tcdLName decl),
 123                           mk_cls_edges (unLoc (tcdCtxt decl)))
 124                 | ldecl@(L _ decl) <- decls, isClassDecl decl ]
 125
 126     mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
 127 \end{code}
 128
 129
 130 %************************************************************************
 131 %*                                                                      *
 132         Deciding which type constructors are recursive
 133 %*                                                                      *
 134 %************************************************************************
 135
 136 For newtypes, we label some as "recursive" such that
 137
 138     INVARIANT: there is no cycle of non-recursive newtypes
 139
 140 In any loop, only one newtype need be marked as recursive; it is
 141 a "loop breaker".  Labelling more than necessary as recursive is OK,
 142 provided the invariant is maintained.
 143
 144 A newtype M.T is defined to be "recursive" iff
 145         (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
 146         (b) it is declared in a source file, but that source file has a
 147             companion hi-boot file which declares the type
 148    or   (c) one can get from T's rhs to T via type
 149             synonyms, or non-recursive newtypes *in M*
 150              e.g.  newtype T = MkT (T -> Int)
 151
 152 (a) is conservative; declarations in hi-boot files are always
 153         made loop breakers. That's why in (b) we can restrict attention
 154         to tycons in M, because any loops through newtypes outside M
 155         will be broken by those newtypes
 156 (b) ensures that a newtype is not treated as a loop breaker in one place
 157 and later as a non-loop-breaker.  This matters in GHCi particularly, when
 158 a newtype T might be embedded in many types in the environment, and then
 159 T's source module is compiled.  We don't want T's recursiveness to change.
 160
 161 The "recursive" flag for algebraic data types is irrelevant (never consulted)
 162 for types with more than one constructor.
 163
 164 An algebraic data type M.T is "recursive" iff
 165         it has just one constructor, and
 166         (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
 167         (b) it is declared in a source file, but that source file has a
 168             companion hi-boot file which declares the type
 169  or     (c) 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 Just like newtype in fact
 173
 174 A type synonym is recursive if one can get from its
 175 right hand side back to it via type synonyms.  (This is
 176 reported as an error.)
 177
 178 A class is recursive if one can get from its superclasses
 179 back to it.  (This is an error too.)
 180
 181 Hi-boot types
 182 ~~~~~~~~~~~~~
 183 A data type read from an hi-boot file will have an AbstractTyCon as its AlgTyConRhs
 184 and will respond True to isHiBootTyCon. The idea is that we treat these as if one
 185 could get from these types to anywhere.  So when we see
 186
 187         module Baz where
 188         import {-# SOURCE #-} Foo( T )
 189         newtype S = MkS T
 190
 191 then we mark S as recursive, just in case. What that means is that if we see
 192
 193         import Baz( S )
 194         newtype R = MkR S
 195
 196 then we don't need to look inside S to compute R's recursiveness.  Since S is imported
 197 (not from an hi-boot file), one cannot get from R back to S except via an hi-boot file,
 198 and that means that some data type will be marked recursive along the way.  So R is
 199 unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary)
 200
 201 This in turn means that we grovel through fewer interface files when computing
 202 recursiveness, because we need only look at the type decls in the module being
 203 compiled, plus the outer structure of directly-mentioned types.
 204
 205 \begin{code}
 206 calcRecFlags :: ModDetails -> [TyThing] -> (Name -> RecFlag)
 207 -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
 208 -- Any type constructors in boot_names are automatically considered loop breakers
 209 calcRecFlags boot_details tyclss
 210   = is_rec
 211   where
 212     is_rec n | n `elemNameSet` rec_names = Recursive
 213              | otherwise                 = NonRecursive
 214
 215     boot_name_set = availsToNameSet (md_exports boot_details)
 216     rec_names = boot_name_set     `unionNameSets`
 217                 nt_loop_breakers  `unionNameSets`
 218                 prod_loop_breakers
 219
 220     all_tycons = [ tc | tycls <- tyclss,
 221                            -- Recursion of newtypes/data types can happen via
 222                            -- the class TyCon, so tyclss includes the class tycons
 223                         let tc = getTyCon tycls,
 224                         not (tyConName tc `elemNameSet` boot_name_set) ]
 225                            -- Remove the boot_name_set because they are going
 226                            -- to be loop breakers regardless.
 227
 228         -------------------------------------------------
 229         --                      NOTE
 230         -- These edge-construction loops rely on
 231         -- every loop going via tyclss, the types and classes
 232         -- in the module being compiled.  Stuff in interface
 233         -- files should be correctly marked.  If not (e.g. a
 234         -- type synonym in a hi-boot file) we can get an infinite
 235         -- loop.  We could program round this, but it'd make the code
 236         -- rather less nice, so I'm not going to do that yet.
 237
 238         --------------- Newtypes ----------------------
 239     new_tycons = filter isNewTyConAndNotOpen all_tycons
 240     isNewTyConAndNotOpen tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
 241     nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
 242     is_rec_nt tc = tyConName tc  `elemNameSet` nt_loop_breakers
 243         -- is_rec_nt is a locally-used helper function
 244
 245     nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
 246
 247     mk_nt_edges nt      -- Invariant: nt is a newtype
 248         = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
 249                         -- tyConsOfType looks through synonyms
 250
 251     mk_nt_edges1 nt tc
 252         | tc `elem` new_tycons = [tc]           -- Loop
 253                 -- At this point we know that either it's a local *data* type,
 254                 -- or it's imported.  Either way, it can't form part of a newtype cycle
 255         | otherwise = []
 256
 257         --------------- Product types ----------------------
 258         -- The "prod_tycons" are the non-newtype products
 259     prod_tycons = [tc | tc <- all_tycons,
 260                         not (isNewTyCon tc), isProductTyCon tc]
 261     prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
 262
 263     prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
 264
 265     mk_prod_edges tc    -- Invariant: tc is a product tycon
 266         = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
 267
 268     mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty)
 269
 270     mk_prod_edges2 ptc tc
 271         | tc `elem` prod_tycons   = [tc]                -- Local product
 272         | tc `elem` new_tycons    = if is_rec_nt tc     -- Local newtype
 273                                     then []
 274                                     else mk_prod_edges1 ptc (new_tc_rhs tc)
 275                 -- At this point we know that either it's a local non-product data type,
 276                 -- or it's imported.  Either way, it can't form part of a cycle
 277         | otherwise = []
 278
 279 new_tc_rhs tc = snd (newTyConRhs tc)    -- Ignore the type variables
 280
 281 getTyCon (ATyCon tc) = tc
 282 getTyCon (AClass cl) = classTyCon cl
 283
 284 findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
 285 -- Finds a set of tycons that cut all loops
 286 findLoopBreakers deps
 287   = go [(tc,tc,ds) | (tc,ds) <- deps]
 288   where
 289     go edges = [ name
 290                | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
 291                  name <- tyConName tc : go edges']
 292 \end{code}
 293
 294 These two functions know about type representations, so they could be
 295 in Type or TcType -- but they are very specialised to this module, so
 296 I've chosen to put them here.
 297
 298 \begin{code}
 299 tcTyConsOfType :: Type -> [TyCon]
 300 -- tcTyConsOfType looks through all synonyms, but not through any newtypes.
 301 -- When it finds a Class, it returns the class TyCon.  The reaons it's here
 302 -- (not in Type.lhs) is because it is newtype-aware.
 303 tcTyConsOfType ty
 304   = nameEnvElts (go ty)
 305   where
 306      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
 307      go ty | Just ty' <- tcView ty = go ty'
 308      go (TyVarTy v)                = emptyNameEnv
 309      go (TyConApp tc tys)          = go_tc tc tys
 310      go (AppTy a b)                = go a `plusNameEnv` go b
 311      go (FunTy a b)                = go a `plusNameEnv` go b
 312      go (PredTy (IParam _ ty))     = go ty
 313      go (PredTy (ClassP cls tys))  = go_tc (classTyCon cls) tys
 314      go (ForAllTy _ ty)            = go ty
 315
 316      go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
 317      go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
 318 \end{code}