-Sadly, I don't think the one using the magic typechecker substitution
-can be done with @apply_to_Id@. Here we go....
-
-Strictness is very important here. We can't leave behind thunks
-with pointers to the substitution: it {\em must} be single-threaded.
-
-\begin{code}
-{-LATER:
-applySubstToId :: Subst -> Id -> (Subst, Id)
-
-applySubstToId subst id@(Id u ty info details)
- -- *cannot* have a "idHasNoFreeTyVars" get-out clause
- -- because, in the typechecker, we are still
- -- *concocting* the types.
- = case (applySubstToTy subst ty) of { (s2, new_ty) ->
- case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
- case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
- (s4, Id u new_ty new_info new_details) }}}
- where
- apply_to_details subst _ (InstId inst no_ftvs)
- = case (applySubstToInst subst inst) of { (s2, new_inst) ->
- (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
-
- apply_to_details subst new_ty (SpecId unspec ty_maybes _)
- = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
- case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
- (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
- -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
- where
- apply_to_maybe subst Nothing = (subst, Nothing)
- apply_to_maybe subst (Just ty)
- = case (applySubstToTy subst ty) of { (s2, new_ty) ->
- (s2, Just new_ty) }
-
- apply_to_details subst _ (WorkerId unwrkr)
- = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
- (s2, WorkerId new_unwrkr) }
-
- apply_to_details subst _ other = (subst, other)
--}
-\end{code}
-
-\begin{code}
-getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
-
-getIdNamePieces show_uniqs id
- = get (unsafeGenId2Id id)
- where
- get (Id u _ details _ _)
- = case details of
- DataConId n _ _ _ _ _ _ _ ->
- case (nameOrigName n) of { (mod, name) ->
- if isPreludeDefinedName n then [name] else [mod, name] }
-
- TupleConId n _ -> [snd (nameOrigName n)]
-
- RecordSelId lbl -> panic "getIdNamePieces:RecordSelId"
-
- ImportedId n -> get_fullname_pieces n
- PreludeId n -> get_fullname_pieces n
- TopLevId n -> get_fullname_pieces n
-
- SuperDictSelId c sc ->
- case (getOrigName c) of { (c_mod, c_name) ->
- case (getOrigName sc) of { (sc_mod, sc_name) ->
- let
- c_bits = if isPreludeDefined c
- then [c_name]
- else [c_mod, c_name]
-
- sc_bits= if isPreludeDefined sc
- then [sc_name]
- else [sc_mod, sc_name]
- in
- [SLIT("sdsel")] ++ c_bits ++ sc_bits }}
-
- MethodSelId clas op ->
- case (getOrigName clas) of { (c_mod, c_name) ->
- case (getClassOpString op) of { op_name ->
- if isPreludeDefined clas
- then [op_name]
- else [c_mod, c_name, op_name]
- } }
-
- DefaultMethodId clas op _ ->
- case (getOrigName clas) of { (c_mod, c_name) ->
- case (getClassOpString op) of { op_name ->
- if isPreludeDefined clas
- then [SLIT("defm"), op_name]
- else [SLIT("defm"), c_mod, c_name, op_name] }}
-
- DictFunId c ty _ _ ->
- case (getOrigName c) of { (c_mod, c_name) ->
- let
- c_bits = if isPreludeDefined c
- then [c_name]
- else [c_mod, c_name]
-
- ty_bits = getTypeString ty
- in
- [SLIT("dfun")] ++ c_bits ++ ty_bits }
-
- ConstMethodId c ty o _ _ ->
- case (getOrigName c) of { (c_mod, c_name) ->
- case (getTypeString ty) of { ty_bits ->
- case (getClassOpString o) of { o_name ->
- case (if isPreludeDefined c
- then [c_name]
- else [c_mod, c_name]) of { c_bits ->
- [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
-
- -- if the unspecialised equiv is "top-level",
- -- the name must be concocted from its name and the
- -- names of the types to which specialised...
-
- SpecId unspec ty_maybes _ ->
- get unspec ++ (if not (toplevelishId unspec)
- then [showUnique u]
- else concat (map typeMaybeString ty_maybes))
-
- WorkerId unwrkr ->
- get unwrkr ++ (if not (toplevelishId unwrkr)
- then [showUnique u]
- else [SLIT("wrk")])
-
- LocalId n _ -> let local = getLocalName n in
- if show_uniqs then [local, showUnique u] else [local]
- InstId n _ -> [getLocalName n, showUnique u]
- SysLocalId n _ -> [getLocalName n, showUnique u]
- SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
-
-get_fullname_pieces :: Name -> [FAST_STRING]
-get_fullname_pieces n
- = BIND (nameOrigName n) _TO_ (mod, name) ->
- if isPreludeDefinedName n
- then [name]
- else [mod, name]
- BEND
-\end{code}