-
-========================= OLD CODE SCEDULED FOR DELETION SLPJ Nov 96 ==============
-
-\begin{code}
-{- COMMENTED OUT
-
-Certain pragmas expect to be pinned onto certain constructs.
-
-Pragma types may be parameterised, just as with any other
-abstract-syntax type.
-
-For a @data@ declaration---indicates which specialisations exist.
-\begin{code}
-data DataPragmas name
- = NoDataPragmas
- | DataPragmas [[Maybe (HsType name)]] -- types to which specialised
-
-noDataPragmas = NoDataPragmas
-isNoDataPragmas NoDataPragmas = True
-\end{code}
-
-These are {\em general} things you can know about any value:
-\begin{code}
-data GenPragmas name
- = NoGenPragmas
- | GenPragmas (Maybe Int) -- arity (maybe)
- (Maybe UpdateInfo) -- update info (maybe)
- (ImpStrictness name) -- strictness, worker-wrapper
- (ImpUnfolding name) -- unfolding (maybe)
- [([Maybe (HsType name)], -- Specialisations: types to which spec'd;
- Int, -- # dicts to ignore
- GenPragmas name)] -- Gen info about the spec'd version
-
-noGenPragmas = NoGenPragmas
-
-isNoGenPragmas NoGenPragmas = True
-isNoGenPragmas _ = False
-
-data ImpUnfolding name
- = NoImpUnfolding
- | ImpMagicUnfolding FAST_STRING -- magic "unfolding"
- -- known to the compiler by "String"
- | ImpUnfolding UnfoldingGuidance -- always, if you like, etc.
- (UnfoldingCoreExpr name)
-
-data ImpStrictness name
- = NoImpStrictness
- | ImpStrictness Bool -- True <=> bottoming Id
- [Demand] -- demand info
- (GenPragmas name) -- about the *worker*
-\end{code}
-
-For an ordinary imported function: it can have general pragmas (only).
-
-For a class's super-class dictionary selectors:
-\begin{code}
-data ClassPragmas name
- = NoClassPragmas
- | SuperDictPragmas [GenPragmas name] -- list mustn't be empty
-
-noClassPragmas = NoClassPragmas
-
-isNoClassPragmas NoClassPragmas = True
-isNoClassPragmas _ = False
-\end{code}
-
-For a class's method selectors:
-\begin{code}
-data ClassOpPragmas name
- = NoClassOpPragmas
- | ClassOpPragmas (GenPragmas name) -- for method selector
- (GenPragmas name) -- for default method
-
-
-noClassOpPragmas = NoClassOpPragmas
-
-isNoClassOpPragmas NoClassOpPragmas = True
-isNoClassOpPragmas _ = False
-\end{code}
-
-\begin{code}
-data InstancePragmas name
- = NoInstancePragmas
-
- | SimpleInstancePragma -- nothing but for the dfun itself...
- (GenPragmas name)
-
- | ConstantInstancePragma
- (GenPragmas name) -- for the "dfun" itself
- [(name, GenPragmas name)] -- one per class op
-
- | SpecialisedInstancePragma
- (GenPragmas name) -- for its "dfun"
- [([Maybe (HsType name)], -- specialised instance; type...
- Int, -- #dicts to ignore
- InstancePragmas name)] -- (no SpecialisedInstancePragma please!)
-
-noInstancePragmas = NoInstancePragmas
-
-isNoInstancePragmas NoInstancePragmas = True
-isNoInstancePragmas _ = False
-\end{code}
-
-Some instances for printing (just for debugging, really)
-\begin{code}
-instance Outputable name => Outputable (ClassPragmas name) where
- ppr NoClassPragmas = empty
- ppr (SuperDictPragmas sdsel_prags)
- = ($$) (ptext SLIT("{-superdict pragmas-}"))
- (ppr sdsel_prags)
-
-instance Outputable name => Outputable (ClassOpPragmas name) where
- ppr NoClassOpPragmas = empty
- ppr (ClassOpPragmas op_prags defm_prags)
- = ($$) (hsep [ptext SLIT("{-meth-}"), ppr op_prags])
- (hsep [ptext SLIT("{-defm-}"), ppr defm_prags])
-
-instance Outputable name => Outputable (InstancePragmas name) where
- ppr NoInstancePragmas = empty
- ppr (SimpleInstancePragma dfun_pragmas)
- = hsep [ptext SLIT("{-dfun-}"), ppr dfun_pragmas]
- ppr (ConstantInstancePragma dfun_pragmas name_pragma_pairs)
- = ($$) (hsep [ptext SLIT("{-constm-}"), ppr dfun_pragmas])
- (vcat (map pp_pair name_pragma_pairs))
- where
- pp_pair (n, prags)
- = hsep [ppr n, equals, ppr prags]
-
- ppr (SpecialisedInstancePragma dfun_pragmas spec_pragma_info)
- = ($$) (hsep [ptext SLIT("{-spec'd-}"), ppr dfun_pragmas])
- (vcat (map pp_info spec_pragma_info))
- where
- pp_info (ty_maybes, num_dicts, prags)
- = hcat [brackets (hsep (map pp_ty ty_maybes)),
- parens (int num_dicts), equals, ppr prags]
- pp_ty Nothing = ptext SLIT("_N_")
- pp_ty (Just t)= ppr t
-
-instance Outputable name => Outputable (GenPragmas name) where
- ppr NoGenPragmas = empty
- ppr (GenPragmas arity_maybe upd_maybe def strictness unfolding specs)
- = hsep [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def?
- pp_str strictness, pp_unf unfolding,
- pp_specs specs]
- where
- pp_arity Nothing = empty
- pp_arity (Just i) = (<>) (ptext SLIT("ARITY=")) (int i)
-
- pp_upd Nothing = empty
- pp_upd (Just u) = ppUpdateInfo u
-
- pp_str NoImpStrictness = empty
- pp_str (ImpStrictness is_bot demands wrkr_prags)
- = hcat [ptext SLIT("IS_BOT="), ppr is_bot,
- ptext SLIT("STRICTNESS="), text (showList demands ""),
- ptext SLIT(" {"), ppr wrkr_prags, char '}']
-
- pp_unf NoImpUnfolding = ptext SLIT("NO_UNFOLDING")
- pp_unf (ImpMagicUnfolding m) = (<>) (ptext SLIT("MAGIC=")) (ptext m)
- pp_unf (ImpUnfolding g core) = (<>) (ptext SLIT("UNFOLD=")) (ppr core)
-
- pp_specs [] = empty
- pp_specs specs
- = hcat [ptext SLIT("SPECS=["), hsep (map pp_spec specs), char ']']
- where
- pp_spec (ty_maybes, num_dicts, gprags)
- = hsep [brackets (hsep (map pp_MaB ty_maybes)), int num_dicts, ppr gprags]
-
- pp_MaB Nothing = ptext SLIT("_N_")
- pp_MaB (Just x) = ppr x
-\end{code}
-
-
-\begin{code}
--}
-\end{code}