-type TidyM a state = Module
- -> UniqFM CoreBinder -- Maps Ids to Ids, TyVars to TyVars etc
- -> state
- -> (a, state)
-
-type TopTidyM a = TidyM a Unique
-type NestTidyM a = TidyM a (Unique, -- Global names
- Unique, -- Local names
- Bag CoreBinding) -- Floats
-
-
-(initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
-
-initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
-initTM mod env m
- = case m mod env initialTopTidyUnique of
- (result, _) -> result
-
-initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
-initNestedTM m mod env global_us
- = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
- (result, (global_us', _, floats)) -> ((result, floats), global_us')
-
-returnTM v mod env usf = (v, usf)
-thenTM m k mod env usf = case m mod env usf of
- (r, usf') -> k r mod env usf'
-
-mapTM f [] = returnTM []
-mapTM f (x:xs) = f x `thenTM` \ r ->
- mapTM f xs `thenTM` \ rs ->
- returnTM (r:rs)
-\end{code}
-
-
-\begin{code}
--- Need to extend the environment when we munge a binder, so that occurrences
--- of the binder will print the correct way (i.e. as a global not a local)
-mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
-mungeTopBinder id thing_inside mod env us
- = case lookupIdEnv env id of
- Just (ValBinder global) -> thing_inside global mod env us -- Already bound
-
- other -> -- Give it a new print-name unless it's an exported thing
- -- setNameVisibility also does the local/global thing
- let
- (id', us') | isExported id = (id, us)
- | otherwise
- = (setIdVisibility (Just mod) us id,
- incrUnique us)
-
- new_env = addToUFM env id (ValBinder id')
- in
- thing_inside id' mod new_env us'
-
-mungeTopBinders [] k = k []
-mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
- mungeTopBinders bs $ \ bs' ->
- k (b' : bs')
-
-addTopFloat :: Type -> CoreExpr -> NestTidyM Id
-addTopFloat lit_ty lit_rhs mod env (gus, lus, floats)
- = let
- gus' = incrUnique gus
- lit_local = mkSysLocal SLIT("lit") gus lit_ty noSrcLoc
- lit_id = setIdVisibility (Just mod) gus lit_local
- in
- (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
-
-lookupId :: Id -> TidyM Id state
-lookupId v mod env usf
- = case lookupUFM env v of
- Nothing -> (v, usf)
- Just (ValBinder v') -> (v', usf)
-
-extendEnvTM :: Id -> Id -> (TidyM a state) -> TidyM a state
-extendEnvTM v v' m mod env usf
- = m mod (addOneToIdEnv env v (ValBinder v')) usf
-\end{code}
-
-
-Making new local binders
-~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-newId id thing_inside mod env (gus, local_uniq, floats)
- = let
- -- Give the Id a fresh print-name, *and* rename its type
- local_uniq' = incrUnique local_uniq
- rn_id = setIdVisibility Nothing local_uniq id
- id' = apply_to_Id (nmbr_ty env local_uniq') rn_id
- env' = addToUFM env id (ValBinder id')
- in
- thing_inside id' mod env' (gus, local_uniq', floats)
-
-newIds [] thing_inside
- = thing_inside []
-newIds (bndr:bndrs) thing_inside
- = newId bndr $ \ bndr' ->
- newIds bndrs $ \ bndrs' ->
- thing_inside (bndr' : bndrs')
-
-
-newTyVar tyvar thing_inside mod env (gus, local_uniq, floats)
- = let
- local_uniq' = incrUnique local_uniq
- tyvar' = nameTyVar tyvar (uniqToOccName local_uniq)
- env' = addToUFM env tyvar (TyBinder tyvar')
- in
- thing_inside tyvar' mod env' (gus, local_uniq', floats)
-
-newUVar uvar thing_inside mod env (gus, local_uniq, floats)
- = let
- local_uniq' = incrUnique local_uniq
- uvar' = cloneUVar uvar local_uniq
- env' = addToUFM env uvar (UsageBinder uvar')
- in
- thing_inside uvar' mod env' (gus, local_uniq', floats)
-\end{code}
-
-Re-numbering types
-~~~~~~~~~~~~~~~~~~
-\begin{code}
-tidyTy ty mod env usf@(_, local_uniq, _)
- = (nmbr_ty env local_uniq ty, usf)
- -- We can use local_uniq as a base for renaming forall'd variables
- -- in the type; we don't need to know how many are consumed.
-
--- This little impedance-matcher calls nmbrType with the right arguments
-nmbr_ty env uniq ty
- = nmbrType tv_env u_env uniq ty