compiler/typecheck/TcTyDecls.lhs

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