-Computing the tyConArgVrcs info
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-@tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
-tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
-separately. Note that this is information about occurrences of type
-variables, not usages of term variables.
-
-The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
-syntycons only* such that all tycons referred to (by mutual recursion)
-appear in the list. The fixpointing will be done on this set of
-tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to
-be (knot-tyingly?) stuck back into the appropriate fields.
-
-\begin{code}
-calcTyConArgVrcs :: [TyCon]
- -> FiniteMap Name ArgVrcs
-
-calcTyConArgVrcs tycons
- = let oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
- initial tc = if isAlgTyCon tc && null (tyConDataCons tc) then
- -- make pessimistic assumption (and warn)
- take (tyConArity tc) abstractVrcs
- else
- replicate (tyConArity tc) (False,False)
- oi'' = tcaoFix oi
- go (tc,vrcs) = (getName tc,vrcs)
- in listToFM (map go (fmToList oi''))
-
- where
-
- tcaoFix :: FiniteMap TyCon ArgVrcs -- initial ArgVrcs per tycon
- -> FiniteMap TyCon ArgVrcs -- fixpointed ArgVrcs per tycon
-
- tcaoFix oi = let (changed,oi') = foldFM (\ tc pms
- (changed,oi')
- -> let pms' = tcaoIter oi' tc -- seq not simult
- in (changed || (pms /= pms'),
- addToFM oi' tc pms'))
- (False,oi) -- seq not simult for faster fixpting
- oi
- in if changed
- then tcaoFix oi'
- else oi'
-
- tcaoIter :: FiniteMap TyCon ArgVrcs -- reference ArgVrcs (initial)
- -> TyCon -- tycon to update
- -> ArgVrcs -- new ArgVrcs for tycon
-
- tcaoIter oi tc | isAlgTyCon tc
- = let cs = tyConDataCons tc
- vs = tyConTyVars tc
- argtys = concatMap dataConRawArgTys cs
- exdicttys = concatMap ((\ (_,_,_,exth,_,_) -> map (uncurry mkDictTy) exth)
- . dataConSig) cs
- myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
- tyConArgVrcs_maybe tc)
- tc
- -- we use the already-computed result for tycons not in this SCC
- in map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) (exdicttys ++ argtys))
- vs
-
- tcaoIter oi tc | isSynTyCon tc
- = let (tyvs,ty) = getSynTyConDefn tc
- myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Syn)" $
- tyConArgVrcs_maybe tc)
- tc
- -- we use the already-computed result for tycons not in this SCC
- in map (\v -> vrcInTy myfao v ty) tyvs
-
-
-abstractVrcs :: ArgVrcs
--- we pull this out as a CAF so the warning only appears *once*
-abstractVrcs = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n"
- ++ "\tUse -fno-prune-tydecls to fix.") $
- repeat (True,True)