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