-- not been injected, so we have to add them manually here
-- We don't include the strange data-con *workers* because they are
-- implicit in the data type declaration itself
-mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, cg_binds = binds})
- = (C.Module mname tdefs (runCoreM (mapM (make_vdef True) binds)
- this_mod))
+mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons,
+ cg_binds = binds})
+ -- Note that we flatten binds at the top level:
+ -- every module is just a single recursive bag of declarations.
+ -- Rationale: since modules can be mutually recursive,
+ -- there's not much reason to preserve dependency info within a module.
+ = C.Module mname tdefs (case flattenBinds binds of
+ -- check for empty list so we don't create an
+ -- empty Rec group
+ [] -> []
+ bs -> [(runCoreM (make_vdef True
+ (Rec bs)) this_mod)])
where
mname = make_mid this_mod
tdefs = foldr collect_tdefs [] tycons
| isAlgTyCon tcon = tdef: tdefs
where
tdef | isNewTyCon tcon =
- C.Newtype (qtc tcon) (map make_tbind tyvars)
+ C.Newtype (qtc tcon)
(case newTyConCo_maybe tcon of
- Just co -> (qtc co,
- map make_tbind vs,
- make_kind (mkCoKind l r))
- where (vs,l,r) = coercionAxiom co
+ Just co -> qtc co
Nothing -> pprPanic ("MkExternalCore: newtype tcon\
should have a coercion: ") (ppr tcon))
+ (map make_tbind tyvars)
repclause
| otherwise =
C.Data (qtc tcon) (map make_tbind tyvars)
where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing
| otherwise = Just (make_ty (snd (newTyConRhs tcon)))
tyvars = tyConTyVars tcon
- coercionAxiom co =
- case isCoercionTyCon_maybe co of
- -- See Note [Newtype coercions] in
- -- types/TyCon
- Just (arity,coKindFun) | (l,r) <- (coKindFun $ map mkTyVarTy vs) ->
- (vs,l,r) where vs = take arity tyvars
- Nothing -> pprPanic "MkExternalCore: coercion tcon lacks a kind fun"
- (ppr tcon)
collect_tdefs _ tdefs = tdefs
{- Id generation. -}
make_id :: Bool -> Name -> C.Id
-make_id _is_var nm = (occNameString . nameOccName) nm
+-- include uniques for internal names in order to avoid name shadowing
+make_id _is_var nm = ((occNameString . nameOccName) nm)
+ ++ (if isInternalName nm then (show . nameUnique) nm else "")
make_var_id :: Name -> C.Id
make_var_id = make_id True