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