%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[TcPragmas]{Typecheck ``pragmas'' of various kinds}
tcClassOpPragmas,
tcDataPragmas,
tcDictFunPragmas,
- tcGenPragmas,
- tcTypePragmas
+ tcGenPragmas
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-import Outputable
-
import TcMonad -- typechecking monadic machinery
-import TcMonadFns ( mkIdsWithGivenTys )
-import AbsSyn -- the stuff being typechecked
+import HsSyn -- the stuff being typechecked
-import AbsPrel ( PrimOp(..) -- to see CCallOp
+import PrelInfo ( PrimOp(..) -- to see CCallOp
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType
-import CE ( lookupCE, nullCE, CE(..) )
+import Type
import CmdLineOpts
import CostCentre
-import E
-import Errors
import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
import Id
import IdInfo
-import WwLib ( mkWwBodies )
-import InstEnv ( lookupClassInstAtSimpleType )
+--import WwLib ( mkWwBodies )
import Maybes ( assocMaybe, catMaybes, Maybe(..) )
-import CoreLint ( lintUnfolding )
-import PlainCore
-import TCE ( TCE(..), UniqFM )
-import TVE
-import TcMonoType ( tcMonoType )
-import TcPolyType ( tcPolyType )
+--import CoreLint ( lintUnfolding )
+import TcMonoType ( tcMonoType, tcPolyType )
import Util
import SrcLoc
\end{code}
\begin{code}
tcClassOpPragmas :: E -- Class/TyCon lookup tables
- -> UniType -- global type of the class method
+ -> Type -- global type of the class method
-> Id -- *final* ClassOpId
-> Id -- *final* DefaultMethodId
-> SpecEnv -- Instance info for this class op
= returnB_Tc (noIdInfo `addInfo` spec_infos, noIdInfo)
tcClassOpPragmas e global_ty
- rec_classop_id rec_defm_id
+ rec_classop_id rec_defm_id
spec_infos
(ClassOpPragmas classop_pragmas defm_pragmas)
= tcGenPragmas e
\begin{code}
tcDictFunPragmas
:: E -- Class/TyCon lookup tables
- -> UniType -- DictFunId type
+ -> Type -- DictFunId type
-> Id -- final DictFunId (don't touch)
-> RenamedInstancePragmas -- info w/ which to complete, giving...
-> Baby_TcM IdInfo -- ... final DictFun IdInfo
\begin{code}
tcGenPragmas
:: E -- lookup table
- -> Maybe UniType -- of Id, if we have it (for convenience)
+ -> Maybe Type -- of Id, if we have it (for convenience)
-> Id -- *incomplete* Id (do not *touch*!)
-> RenamedGenPragmas -- info w/ which to complete, giving...
-> Baby_TcM IdInfo -- IdInfo for this Id
-- Same as unfolding; if we fail, don't junk all IdInfo
recoverIgnoreErrorsB_Tc nullSpecEnv (
tc_specs e rec_final_id ty_maybe specs
- ) `thenB_Tc` \ spec_env ->
+ ) `thenB_Tc` \ spec_env ->
returnB_Tc (
noIdInfo
\begin{code}
tc_strictness
:: E
- -> Maybe UniType
+ -> Maybe Type
-> Id -- final Id (do not *touch*)
-> ImpStrictness Name
-> Baby_TcM (StrictnessInfo, UnfoldingDetails)
-- go wrong if there's an abstract type involved, mind you.
let
(tv_tmpls, arg_tys, ret_ty) = splitTypeWithDictsAsArgs wrapper_ty
- n_wrapper_args = length wrap_arg_info
- -- Don't have more args than this, else you risk
+ n_wrapper_args = length wrap_arg_info
+ -- Don't have more args than this, else you risk
-- losing laziness!!
in
getUniquesB_Tc (length tv_tmpls) `thenB_Tc` \ tyvar_uniqs ->
getUniquesB_Tc n_wrapper_args `thenB_Tc` \ arg_uniqs ->
-
+
let
- (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
+ (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
inst_arg_tys = map (instantiateTy inst_env) arg_tys
(undropped_inst_arg_tys, dropped_inst_arg_tys)
inst_ret_ty = glueTyArgs dropped_inst_arg_tys
(instantiateTy inst_env ret_ty)
- args = zipWith mk_arg arg_uniqs undropped_inst_arg_tys
+ args = zipWithEqual mk_arg arg_uniqs undropped_inst_arg_tys
mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc
-- ASSERT: length args = n_wrapper_args
in
Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
- let
+ let
worker_ty = worker_ty_w_hole inst_ret_ty
in
getUniqueB_Tc `thenB_Tc` \ uniq ->
wrapper_rhs = wrapper_w_hole worker_id
n_tyvars = length tyvars
arity = length args
-
+
in
returnB_Tc (
mkStrictnessInfo wrap_arg_info (Just worker_id),
\begin{code}
tc_specs :: E
-> Id -- final Id for which these are specialisations (do not *touch*)
- -> Maybe UniType
+ -> Maybe Type
-> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)]
-> Baby_TcM SpecEnv
returnB_Tc (mkSpecEnv spec_infos)
where
(main_tyvars, _) = splitForalls main_ty
-
+
rec_ce = getE_CE e
rec_tce = getE_TCE e
(badSpecialisationErr "value" "wrong number of specialising types"
(length main_tyvars) maybe_tys locn)
`thenB_Tc_`
- let
+ let
spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore
in
fixB_Tc ( \ rec_spec_id ->
(lint_guidance, lint_expr) = case maybe_lint_expr of
Just lint_expr -> (guidance, lint_expr)
- Nothing -> (BadUnfolding, panic_expr)
+ Nothing -> (BadUnfolding, panic_expr)
in
returnB_Tc (mkUnfolding lint_guidance lint_expr)
where
-- (others: we hope we can figure them out)
-> TVE -- lookup table for tyvars
-> UnfoldingCoreExpr Name
- -> Baby_TcM PlainCoreExpr
+ -> Baby_TcM CoreExpr
- tc_uf_core lve tve (UfCoVar v)
+ tc_uf_core lve tve (UfVar v)
= tc_uf_Id lve v `thenB_Tc` \ id ->
- returnB_Tc (CoVar id)
+ returnB_Tc (Var id)
- tc_uf_core lve tve (UfCoLit l)
- = returnB_Tc (CoLit l)
+ tc_uf_core lve tve (UfLit l)
+ = returnB_Tc (Lit l)
- tc_uf_core lve tve (UfCoCon con tys as)
+ tc_uf_core lve tve (UfCon con tys as)
= tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
- returnB_Tc (CoCon con_id core_tys core_atoms)
+ returnB_Tc (Con con_id core_tys core_atoms)
-- If a ccall, we have to patch in the types read from the pragma.
- tc_uf_core lve tve (UfCoPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
+ tc_uf_core lve tve (UfPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
= ASSERT(null app_tys)
mapB_Tc (tc_uf_type tve) arg_tys `thenB_Tc` \ core_arg_tys ->
- tc_uf_type tve res_ty `thenB_Tc` \ core_res_ty ->
- mapB_Tc (tc_uf_type tve) app_tys `thenB_Tc` \ core_app_tys ->
+ tc_uf_type tve res_ty `thenB_Tc` \ core_res_ty ->
+ mapB_Tc (tc_uf_type tve) app_tys `thenB_Tc` \ core_app_tys ->
mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
- returnB_Tc (CoPrim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
+ returnB_Tc (Prim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
core_app_tys core_atoms)
- tc_uf_core lve tve (UfCoPrim (UfOtherOp op) tys as)
+ tc_uf_core lve tve (UfPrim (UfOtherOp op) tys as)
= mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
- returnB_Tc (CoPrim op core_tys core_atoms)
+ returnB_Tc (Prim op core_tys core_atoms)
- tc_uf_core lve tve (UfCoLam binders body)
- = tc_uf_binders tve binders `thenB_Tc` \ lve2 ->
+ tc_uf_core lve tve (UfLam binder body)
+ = tc_uf_binders tve [binder] `thenB_Tc` \ lve2 ->
let
- new_binders = map snd lve2
+ [new_binder] = map snd lve2
new_lve = lve2 `plusLVE` lve
in
tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (CoLam new_binders new_body)
-
- tc_uf_core lve tve (UfCoTyLam tv body)
- = let
- (new_tv, uniq, new_tv_ty) = tc_uf_tyvar tv
- new_tve = tve `plusTVE` (unitTVE uniq new_tv_ty)
- in
- tc_uf_core lve new_tve body `thenB_Tc` \ new_body ->
- returnB_Tc (CoTyLam new_tv new_body)
+ returnB_Tc (Lam new_binder new_body)
- tc_uf_core lve tve (UfCoApp fun arg)
+ tc_uf_core lve tve (UfApp fun arg)
= tc_uf_core lve tve fun `thenB_Tc` \ new_fun ->
- tc_uf_atom lve tve arg `thenB_Tc` \ new_arg ->
- returnB_Tc (CoApp new_fun new_arg)
-
- tc_uf_core lve tve (UfCoTyApp expr ty)
- = tc_uf_core lve tve expr `thenB_Tc` \ new_expr ->
- tc_uf_type tve ty `thenB_Tc` \ new_ty ->
- returnB_Tc (mkCoTyApp new_expr new_ty)
+ tc_uf_atom lve tve arg `thenB_Tc` \ new_arg ->
+ returnB_Tc (App new_fun new_arg)
- tc_uf_core lve tve (UfCoCase scrut alts)
+ tc_uf_core lve tve (UfCase scrut alts)
= tc_uf_core lve tve scrut `thenB_Tc` \ new_scrut ->
tc_alts alts `thenB_Tc` \ new_alts ->
- returnB_Tc (CoCase new_scrut new_alts)
+ returnB_Tc (Case new_scrut new_alts)
where
tc_alts (UfCoAlgAlts alts deflt)
= mapB_Tc tc_alg_alt alts `thenB_Tc` \ new_alts ->
tc_deflt deflt `thenB_Tc` \ new_deflt ->
- returnB_Tc (CoAlgAlts new_alts new_deflt)
+ returnB_Tc (AlgAlts new_alts new_deflt)
where
tc_alg_alt (con, params, rhs)
= tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
tc_alts (UfCoPrimAlts alts deflt)
= mapB_Tc tc_prim_alt alts `thenB_Tc` \ new_alts ->
tc_deflt deflt `thenB_Tc` \ new_deflt ->
- returnB_Tc (CoPrimAlts new_alts new_deflt)
+ returnB_Tc (PrimAlts new_alts new_deflt)
where
tc_prim_alt (lit, rhs)
= tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
returnB_Tc (lit, new_rhs)
- tc_deflt UfCoNoDefault = returnB_Tc CoNoDefault
+ tc_deflt UfCoNoDefault = returnB_Tc NoDefault
tc_deflt (UfCoBindDefault b rhs)
= tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
let
new_lve = lve2 `plusLVE` lve
in
tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs ->
- returnB_Tc (CoBindDefault new_b new_rhs)
+ returnB_Tc (BindDefault new_b new_rhs)
- tc_uf_core lve tve (UfCoLet (UfCoNonRec b rhs) body)
+ tc_uf_core lve tve (UfLet (UfCoNonRec b rhs) body)
= tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
let
new_lve = lve2 `plusLVE` lve
in
tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (CoLet (CoNonRec new_b new_rhs) new_body)
+ returnB_Tc (Let (NonRec new_b new_rhs) new_body)
- tc_uf_core lve tve (UfCoLet (UfCoRec pairs) body)
+ tc_uf_core lve tve (UfLet (UfCoRec pairs) body)
= let
(binders, rhss) = unzip pairs
in
in
mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss ->
tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (CoLet (CoRec (new_binders `zip` new_rhss)) new_body)
+ returnB_Tc (Let (Rec (new_binders `zip` new_rhss)) new_body)
- tc_uf_core lve tve (UfCoSCC uf_cc body)
+ tc_uf_core lve tve (UfSCC uf_cc body)
= tc_uf_cc uf_cc `thenB_Tc` \ new_cc ->
tc_uf_core lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (CoSCC new_cc new_body)
+ returnB_Tc (SCC new_cc new_body)
where
tc_uf_cc (UfAutoCC id m g is_dupd is_caf)
= tc_uf_Id lve id `thenB_Tc` \ new_id ->
= tc_uf_Id lve id `thenB_Tc` \ new_id ->
returnB_Tc (adjust is_caf is_dupd (mkDictCC new_id m g IsNotCafCC))
- tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
+ tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
- tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
- tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
+ tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
+ tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
--------
adjust is_caf is_dupd cc
---------------
tc_uf_atom lve tve (UfCoLitAtom l)
- = returnB_Tc (CoLitAtom l)
+ = returnB_Tc (LitArg l)
tc_uf_atom lve tve (UfCoVarAtom v)
= tc_uf_Id lve v `thenB_Tc` \ new_v ->
- returnB_Tc (CoVarAtom new_v)
+ returnB_Tc (VarArg new_v)
---------------
tc_uf_binders tve ids_and_tys
dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of
Just id -> id
Nothing -> pprPanic "tc_uf_Id:DictFunUfId:"
- (ppr PprDebug (UfCoVar uf_id))
+ (ppr PprDebug (UfVar uf_id))
-- The class and type are both
-- visible, so the instance should
-- jolly well be too!
= tc_uf_Id lve unspec `thenB_Tc` \ unspec_id ->
mapB_Tc (tc_ty_maybe rec_ce rec_tce) ty_maybes
`thenB_Tc` \ maybe_tys ->
- let
+ let
spec_id = lookupSpecId unspec_id maybe_tys
in
returnB_Tc spec_id
tc_uf_Id lve (WorkerUfId unwrkr)
= tc_uf_Id lve unwrkr `thenB_Tc` \ unwrkr_id ->
- let
+ let
strictness_info = getIdStrictness unwrkr_id
in
if isLocallyDefined unwrkr_id
-- A locally defined value will not have any strictness info (yet),
-- so we can't extract the locally defined worker Id from it :-(
- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
+ pprTrace "WARNING: Discarded bad unfolding from interface:\n"
(ppCat [ppStr "Worker Id in unfolding is defined locally:",
ppr PprDebug unwrkr_id])
(failB_Tc (panic "tc_uf_Id:WorkerUfId: locally defined"))
= getClassOps clas !! (tag - 1)
---------------------------------------------------------------------
- tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM UniType
+ tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM Type
tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty
\end{code}
(length new_tyvars) maybe_tys locn)
`thenB_Tc_`
- returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[tcTypePragmas]{@type@ synonym pragmas}
-%* *
-%************************************************************************
-
-The purpose of a @type@ pragma is to say that the synonym's
-representation should not be used by the user.
-
-\begin{code}
-tcTypePragmas :: TypePragmas
- -> Bool -- True <=> abstract synonym, please
-
-tcTypePragmas NoTypePragmas = False
-tcTypePragmas AbstractTySynonym = True
+ returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
\end{code}
-
projects / ghc-hetmet.git / blobdiff