-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
- eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID,
- rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID,
+
+ mkRuntimeErrorApp,
+ rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
- aBSENT_ERROR_ID, pAR_ERROR_ID
+ pAT_ERROR_ID
) where
#include "HsVersions.h"
-- error-reporting functions that they have an 'open'
-- result type. -- sof 1/99]
- aBSENT_ERROR_ID,
- eRROR_ID,
- eRROR_CSTRING_ID,
+ rUNTIME_ERROR_ID,
iRREFUT_PAT_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID,
nO_METHOD_BINDING_ERROR_ID,
- pAR_ERROR_ID,
pAT_ERROR_ID,
- rEC_CON_ERROR_ID,
- rEC_UPD_ERROR_ID
+ rEC_CON_ERROR_ID
] ++ ghcPrimIds
-- These Ids are exported from GHC.Prim
unN = /\a -> \n:N -> coerce (a->a) n
\begin{code}
-mkRecordSelId tycon field_label unpack_id unpackUtf8_id
+mkRecordSelId tycon field_label
-- Assumes that all fields with the same field label have the same type
--
-- Annoyingly, we have to pass in the unpackCString# Id, because
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
field_lbls = dataConFieldLabels data_con
- error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type field_tau, err_string]
- err_string
- | all safeChar full_msg
- = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
- | otherwise
- = App (Var unpackUtf8_id) (Lit (MachStr (_PK_ (stringToUtf8 (map ord full_msg)))))
- where
- safeChar c = c >= '\1' && c <= '\xFF'
- -- TODO: Putting this Unicode stuff here is ugly. Find a better
- -- generic place to make string literals. This logic is repeated
- -- in DsUtils.
+ error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
templates, but we don't ever expect to generate code for it.
\begin{code}
-eRROR_ID
- = pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy
-eRROR_CSTRING_ID
- = pc_bottoming_Id errorCStringIdKey pREL_ERR FSLIT("errorCString")
- (mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy))
-pAT_ERROR_ID
- = generic_ERROR_ID patErrorIdKey FSLIT("patError")
-rEC_SEL_ERROR_ID
- = generic_ERROR_ID recSelErrIdKey FSLIT("recSelError")
-rEC_CON_ERROR_ID
- = generic_ERROR_ID recConErrorIdKey FSLIT("recConError")
-rEC_UPD_ERROR_ID
- = generic_ERROR_ID recUpdErrorIdKey FSLIT("recUpdError")
-iRREFUT_PAT_ERROR_ID
- = generic_ERROR_ID irrefutPatErrorIdKey FSLIT("irrefutPatError")
-nON_EXHAUSTIVE_GUARDS_ERROR_ID
- = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError")
-nO_METHOD_BINDING_ERROR_ID
- = generic_ERROR_ID noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
-
-aBSENT_ERROR_ID
- = pc_bottoming_Id absentErrorIdKey pREL_ERR FSLIT("absentErr")
- (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
-
-pAR_ERROR_ID
- = pcMiscPrelId parErrorIdKey pREL_ERR FSLIT("parError")
- (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
+mkRuntimeErrorApp
+ :: Id -- Should be of type (forall a. Addr# -> a)
+ -- where Addr# points to a UTF8 encoded string
+ -> Type -- The type to instantiate 'a'
+ -> String -- The string to print
+ -> CoreExpr
+
+mkRuntimeErrorApp err_id res_ty err_msg
+ = mkApps (Var err_id) [Type res_ty, err_string]
+ where
+ err_string = Lit (MachStr (_PK_ (stringToUtf8 err_msg)))
+
+rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrIdKey FSLIT("recSelError")
+rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorIdKey FSLIT("runtimeError")
+
+iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorIdKey FSLIT("irrefutPatError")
+rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorIdKey FSLIT("recConError")
+nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError")
+pAT_ERROR_ID = mkRuntimeErrorId patErrorIdKey FSLIT("patError")
+nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
+
+-- The runtime error Ids take a UTF8-encoded string as argument
+mkRuntimeErrorId key name = pc_bottoming_Id key pREL_ERR name runtimeErrorTy
+runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
\end{code}
\begin{code}
module CoreUtils (
-- Construction
- mkNote, mkInlineMe, mkSCC, mkCoerce,
+ mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
bindNonRec, needsCaseBinding,
mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
\begin{code}
mkNote :: Note -> CoreExpr -> CoreExpr
-mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
+mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
mkNote (SCC cc) expr = mkSCC cc expr
mkNote InlineMe expr = mkInlineMe expr
mkNote note expr = Note note expr
\begin{code}
-mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
+mkCoerce :: Type -> CoreExpr -> CoreExpr
+mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
-mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
+mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
+mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
= ASSERT( from_ty `eqType` to_ty2 )
- mkCoerce to_ty from_ty2 expr
+ mkCoerce2 to_ty from_ty2 expr
-mkCoerce to_ty from_ty expr
+mkCoerce2 to_ty from_ty expr
| to_ty `eqType` from_ty = expr
| otherwise = ASSERT( from_ty `eqType` exprType expr )
Note (Coerce to_ty from_ty) expr
arity = tyConArity tc
val_args = drop arity args
to_arg_tys = dataConArgTys dc tc_arg_tys
- mk_coerce ty arg = mkCoerce ty (exprType arg) arg
+ mk_coerce ty arg = mkCoerce ty arg
new_val_args = zipWith mk_coerce to_arg_tys val_args
in
ASSERT( all isTypeArg (take arity args) )
; Nothing ->
case splitNewType_maybe ty of {
- Just ty' -> mkCoerce ty ty' (eta_expand n us (mkCoerce ty' ty expr) ty') ;
+ Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
}}}
\end{code}
make_cdef :: DataCon -> C.Cdef
make_cdef dcon = C.Constr dcon_name existentials tys
where
- dcon_name = make_con_qid (idName (dataConWorkId dcon))
+ dcon_name = make_con_qid (dataConName dcon)
existentials = map make_tbind ex_tyvars
ex_tyvars = dataConExistentialTyVars dcon
tys = map make_ty (dataConRepArgTys dcon)
make_exp :: CoreExpr -> C.Exp
make_exp (Var v) =
case globalIdDetails v of
- DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
+ -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
+-- DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (_UNPK_ nm) (make_ty (varType v))
FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
_ -> C.Var (make_var_qid (Var.varName v))
make_alt :: CoreAlt -> C.Alt
make_alt (DataAlt dcon, vs, e) =
- C.Acon (make_con_qid (idName (dataConWorkId dcon))) (map make_tbind tbs) (map make_vbind vbs) (make_exp e)
+ C.Acon (make_con_qid (dataConName dcon))
+ (map make_tbind tbs)
+ (map make_vbind vbs)
+ (make_exp e)
where (tbs,vbs) = span isTyVar vs
make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
{- Use encoded strings.
Also, adjust casing to work around some badly-chosen internal names. -}
make_id :: Bool -> Name -> C.Id
+make_id is_var nm = (occNameString . nameOccName) nm
+
+{- SIMON thinks this stuff isn't necessary
make_id is_var nm =
case n of
'Z':cs | is_var -> 'z':cs
c:cs | isLower c && (not is_var) -> 'Z':'d':n
_ -> n
where n = (occNameString . nameOccName) nm
+-}
make_var_id :: Name -> C.Id
make_var_id = make_id True
tc_binds = all_binds,
tc_insts = insts,
tc_rules = rules,
--- tc_cbinds = core_binds,
tc_fords = fo_decls})
= do { showPass dflags "Desugar"
; us <- mkSplitUniqSupply 'd'
(ds_binds, ds_rules, foreign_stuff) = ds_result
-{-
- addCoreBinds ls =
- case core_binds of
- [] -> ls
- cs -> (Rec cs) : ls
--}
mod_details = ModDetails { md_types = type_env,
md_insts = insts,
md_rules = ds_rules,
Simplest thing in the world, desugaring External Core:
\begin{code}
-deSugarCore :: TypeEnv -> [TypecheckedCoreBind]
+deSugarCore :: (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])
-> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr]))
-deSugarCore type_env cs = do
- let
- mod_details
- = ModDetails { md_types = type_env
- , md_insts = []
- , md_rules = []
- , md_binds = [Rec (map (\ (lhs,_,rhs) -> (lhs,rhs)) cs)]
- }
+deSugarCore (type_env, pairs, rules)
+ = return (mod_details, no_foreign_stuff)
+ where
+ mod_details = ModDetails { md_types = type_env
+ , md_insts = []
+ , md_rules = ds_rules
+ , md_binds = ds_binds }
+ ds_binds = [Rec pairs]
+ ds_rules = [(fun,rule) | IfaceRuleOut fun rule <- rules]
no_foreign_stuff = (empty,empty,[],[])
- return (mod_details, no_foreign_stuff)
-
\end{code}
import DsMonad
-import CoreUtils ( exprType, mkCoerce )
+import CoreUtils ( exprType, mkCoerce2 )
import Id ( Id, mkWildId, idType )
import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
import Maybes ( maybeToBool )
-- Recursive newtypes
| Just rep_ty <- splitNewType_maybe arg_ty
- = unboxArg (mkCoerce rep_ty arg_ty arg)
+ = unboxArg (mkCoerce2 rep_ty arg_ty arg)
-- Booleans
| Just (tc,_) <- splitTyConApp_maybe arg_ty,
= let
(maybe_ty, wrapper) = resultWrapper rep_ty
in
- (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e))
+ (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
-- Data types with a single constructor, which has a single arg
| Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
-dsExpr (HsDoOut ListComp stmts return_id then_id fail_id result_ty src_loc)
+dsExpr (HsDoOut ListComp stmts _ result_ty src_loc)
= -- Special case for list comprehensions
putSrcLocDs src_loc $
dsListComp stmts elt_ty
where
(_, [elt_ty]) = tcSplitTyConApp result_ty
-dsExpr (HsDoOut DoExpr stmts return_id then_id fail_id result_ty src_loc)
+dsExpr (HsDoOut DoExpr stmts ids result_ty src_loc)
= putSrcLocDs src_loc $
- dsDo DoExpr stmts return_id then_id fail_id result_ty
+ dsDo DoExpr stmts ids result_ty
-dsExpr (HsDoOut PArrComp stmts return_id then_id fail_id result_ty src_loc)
+dsExpr (HsDoOut PArrComp stmts _ result_ty src_loc)
= -- Special case for array comprehensions
putSrcLocDs src_loc $
dsPArrComp stmts elt_ty
\begin{code}
dsDo :: HsDoContext
-> [TypecheckedStmt]
- -> Id -- id for: return m
- -> Id -- id for: (>>=) m
- -> Id -- id for: fail m
+ -> [Id] -- id for: [return,fail,>>=,>>]
-> Type -- Element type; the whole expression has type (m t)
-> DsM CoreExpr
-dsDo do_or_lc stmts return_id then_id fail_id result_ty
+dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty
= let
(_, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
is_do = case do_or_lc of
| is_do -- Do expression
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
- newSysLocalDs a_ty `thenDs` \ ignored_result_id ->
- returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
- Lam ignored_result_id rest])
+ returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2, rest])
| otherwise -- List comprehension
= do_expr expr locn `thenDs` \ expr2 ->
(HsLit (HsString (_PK_ msg)))
msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
main_match = mkSimpleMatch [pat]
- (HsDoOut do_or_lc stmts return_id then_id
- fail_id result_ty locn)
+ (HsDoOut do_or_lc stmts ids result_ty locn)
result_ty locn
the_matches
| failureFreePat pat = [main_match]
]
in
matchWrapper (DoCtxt do_or_lc) the_matches `thenDs` \ (binders, matching_code) ->
- returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
+ returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, expr2,
mkLams binders matching_code])
in
go stmts
import DsMonad
-import CoreUtils ( exprType, mkIfThenElse )
+import CoreUtils ( exprType, mkIfThenElse, mkCoerce )
import PrelInfo ( iRREFUT_PAT_ERROR_ID )
import MkId ( mkReboxingAlt, mkNewTypeBody )
import Id ( idType, Id, mkWildId )
plusIntegerName, timesIntegerName,
lengthPName, indexPName )
import Outputable
-import UnicodeUtil ( stringToUtf8 )
+import UnicodeUtil ( intsToUtf8, stringToUtf8 )
import Util ( isSingleton, notNull )
\end{code}
= getSrcLocDs `thenDs` \ src_loc ->
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
+ core_msg = Lit (MachStr (_PK_ (stringToUtf8 full_msg)))
in
- mkStringLit full_msg `thenDs` \ core_msg ->
returnDs (mkApps (Var err_id) [Type ty, core_msg])
\end{code}
in
returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
- | all safeChar chars
+ | all safeChar int_chars
= dsLookupGlobalValue unpackCStringName `thenDs` \ unpack_id ->
returnDs (App (Var unpack_id) (Lit (MachStr str)))
| otherwise
= dsLookupGlobalValue unpackCStringUtf8Name `thenDs` \ unpack_id ->
- returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
+ returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (intsToUtf8 int_chars)))))
where
- chars = _UNPK_INT_ str
+ int_chars = _UNPK_INT_ str
safeChar c = c >= 1 && c <= 0xFF
\end{code}
| isSingleton binders || is_simple_pat pat
= newSysLocalDs (exprType val_expr) `thenDs` \ val_var ->
- -- For the error message we don't use mkErrorAppDs to avoid
- -- duplicating the string literal each time
- newSysLocalDs stringTy `thenDs` \ msg_var ->
- getSrcLocDs `thenDs` \ src_loc ->
- let
- full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
- in
- mkStringLit full_msg `thenDs` \ core_msg ->
- mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
+ -- For the error message we make one error-app, to avoid duplication.
+ -- But we need it at different types... so we use coerce for that
+ mkErrorAppDs iRREFUT_PAT_ERROR_ID
+ unitTy (showSDoc (ppr pat)) `thenDs` \ err_expr ->
+ newSysLocalDs unitTy `thenDs` \ err_var ->
+ mapDs (mk_bind val_var err_var) binders `thenDs` \ binds ->
returnDs ( (val_var, val_expr) :
- (msg_var, core_msg) :
+ (err_var, err_expr) :
binds )
local_tuple = mkTupleExpr binders
tuple_ty = exprType local_tuple
- mk_bind scrut_var msg_var bndr_var
- -- (mk_bind sv bv) generates
- -- bv = case sv of { pat -> bv; other -> error-msg }
+ mk_bind scrut_var err_var bndr_var
+ -- (mk_bind sv err_var) generates
+ -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
-- Remember, pat binds bv
= matchSimply (Var scrut_var) PatBindRhs pat
(Var bndr_var) error_expr `thenDs` \ rhs_expr ->
returnDs (bndr_var, rhs_expr)
where
- binder_ty = idType bndr_var
- error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
+ error_expr = mkCoerce (idType bndr_var) (Var err_var)
is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
hsDeclName, instDeclName,
tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, isCoreDecl,
- countTyClDecls,
+ isTypeOrClassDecl, countTyClDecls,
mkClassDeclSysNames, isSourceInstDecl, ifaceRuleDeclName,
getClassDeclSysNames, conDetailsTys,
collectRuleBndrSigTys
isClassDecl (ClassDecl {}) = True
isClassDecl other = False
+isTypeOrClassDecl (ClassDecl {}) = True
+isTypeOrClassDecl (TyData {}) = True
+isTypeOrClassDecl (TySynonym {}) = True
+isTypeOrClassDecl (ForeignType {}) = True
+isTypeOrClassDecl other = False
+
isCoreDecl (CoreDecl {}) = True
isCoreDecl other = False
| HsDoOut HsDoContext
[Stmt id pat] -- "do":one or more stmts
- id -- id for return
- id -- id for >>=
- id -- id for fail
+ [id] -- ids for [return,fail,>>=,>>]
+ -- Brutal but simple
Type -- Type of the whole expression
SrcLoc
= sep [hang (ptext SLIT("let")) 2 (pp_ipbinds binds),
hang (ptext SLIT("in")) 2 (ppr expr)]
-ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
-ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts
+ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
+ppr_expr (HsDoOut do_or_list_comp stmts _ _ _) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ exprs)
= brackets (fsep (punctuate comma (map ppr_expr exprs)))
-----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.18 2002/04/05 15:18:26 sof Exp $
+-- $Id: DriverPhases.hs,v 1.19 2002/04/11 12:03:33 simonpj Exp $
--
-- GHC Driver
--
hsbootish_file, hsbootish_suffix,
objish_file, objish_suffix,
cish_file, cish_suffix,
- isExtCore_file
+ isExtCore_file, extcoreish_suffix
) where
import DriverUtil
import Panic
import Util
+import ParserCoreUtils ( getCoreModuleName )
+
#ifdef GHCI
import Time ( getClockTime )
#endif
writeIORef v_HCHeader cc_injects
-- gather the imports and module name
- (srcimps,imps,mod_name) <- getImportsFromFile input_fn
+ (srcimps,imps,mod_name) <-
+ if extcoreish_suffix suff
+ then do
+ -- no explicit imports in ExtCore input.
+ m <- getCoreModuleName input_fn
+ return ([], [], mkModuleName m)
+ else
+ getImportsFromFile input_fn
-- build a ModuleLocation to pass to hscMain.
(mod, location')
; case front_res of
Left flure -> return flure;
Right (this_mod, rdr_module,
- Just (dont_discard, new_iface, rn_result),
+ dont_discard, new_iface,
pcs_tc, ds_details, foreign_stuff) -> do {
-------------------
-- FLATTENING
<- renameExtCore dflags hit hst pcs_ch this_mod rdr_module
; case maybe_rn_result of {
Nothing -> return (Left (HscFail pcs_ch));
- Just (dont_discard, new_iface, rn_result) -> do {
+ Just (dont_discard, new_iface, rn_decls) -> do {
-------------------
-- TYPECHECK
-------------------
; maybe_tc_result
<- _scc_ "TypeCheck"
- typecheckCoreModule dflags pcs_rn hst new_iface (rr_decls rn_result)
+ typecheckCoreModule dflags pcs_rn hst new_iface rn_decls
; case maybe_tc_result of {
Nothing -> return (Left (HscFail pcs_ch));
- Just (pcs_tc, ty_env, core_binds) -> do {
+ Just (pcs_tc, tc_result) -> do {
-------------------
-- DESUGAR
-------------------
- ; (ds_details, foreign_stuff) <- deSugarCore ty_env core_binds
- ; return (Right (this_mod, rdr_module, maybe_rn_result,
+ ; (ds_details, foreign_stuff) <- deSugarCore tc_result
+ ; return (Right (this_mod, rdr_module, dont_discard, new_iface,
pcs_tc, ds_details, foreign_stuff))
}}}}}}
; (ds_details, foreign_stuff)
<- _scc_ "DeSugar"
deSugar dflags pcs_tc hst this_mod print_unqual tc_result
- ; return (Right (this_mod, rdr_module, maybe_rn_result,
+ ; return (Right (this_mod, rdr_module, dont_discard, new_iface,
pcs_tc, ds_details, foreign_stuff))
}}}}}}}
| tdef ';' tdefs {$1:$3}
tdef :: { RdrNameHsDecl }
- : '%data' qcname tbinds '=' '{' cons1 '}'
+ : '%data' q_tc_name tbinds '=' '{' cons1 '}'
{ TyClD (TyData DataType [] $2 $3 (DataCons $6) Nothing [] noSrcLoc) }
- | '%newtype' qcname tbinds trep
+ | '%newtype' q_tc_name tbinds trep
{ TyClD (TyData NewType [] $2 $3 ($4 $2 $3) Nothing [] noSrcLoc) }
trep :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
| con ';' cons1 { $1:$3 }
con :: { ConDecl RdrName }
- : qcname attbinds atys
+ : q_d_name attbinds atys
{ ConDecl $1 $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc}
atys :: { [ RdrNameHsType] }
aty :: { RdrNameHsType }
: name { HsTyVar $1 }
- | qcname { HsTyVar $1 }
+ | q_tc_name { HsTyVar $1 }
| '(' ty ')' { $2 }
aexp :: { UfExpr RdrName }
: qname { UfVar $1 }
- | qcname { UfVar $1 }
+ | q_d_name { UfVar $1 }
| lit { UfLit $1 }
| '(' exp ')' { $2 }
| alt ';' alts1 { $1:$3 }
alt :: { UfAlt RdrName }
- : qcname attbinds vbinds '->' exp
+ : q_d_name attbinds vbinds '->' exp
{ {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
| lit '->' exp
{ (UfLitAlt $1, [], $3) }
| '(' STRING '::' aty ')' { MachStr (_PK_ $2) }
name :: { RdrName }
- : NAME { mkUnqual varName (_PK_ $1) }
+ : NAME { mkRdrUnqual (mkVarOccEncoded (_PK_ $1)) }
cname :: { String }
: CNAME { $1 }
| mname '.' NAME
{ mkIfaceOrig varName (_PK_ $1,_PK_ $3) }
-qcname :: { RdrName }
+-- Type constructor
+q_tc_name :: { RdrName }
+ : mname '.' cname
+ { mkIfaceOrig tcName (_PK_ $1,_PK_ $3) }
+
+-- Data constructor
+q_d_name :: { RdrName }
: mname '.' cname
{ mkIfaceOrig dataName (_PK_ $1,_PK_ $3) }
{
-
toUfBinder :: [RdrNameHsDecl] -> UfBinding RdrName
toUfBinder xs =
case xs of
happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
}
+
module ParserCoreUtils where
+import IO
+
data ParseResult a = OkP a | FailP String
type P a = String -> Int -> ParseResult a
failP :: String -> P a
failP s s' _ = FailP (s ++ ":" ++ s')
+getCoreModuleName :: FilePath -> IO String
+getCoreModuleName fpath =
+ catch (do
+ h <- openFile fpath ReadMode
+ ls <- hGetContents h
+ let mo = findMod (words ls)
+ -- make sure we close up the file right away.
+ (length mo) `seq` return ()
+ hClose h
+ return mo)
+ (\ _ -> return "Main")
+ where
+ findMod [] = "Main"
+ findMod ("%module":m:_) = m
+ findMod (_:xs) = findMod xs
+
+
data Token =
TKmodule
| TKdata
toEnumName,
eqName,
thenMName,
+ bindMName,
returnMName,
failMName,
fromRationalName,
pREL_TOP_HANDLER_Name = mkModuleName "GHC.TopHandler"
sYSTEM_IO_Name = mkModuleName "System.IO"
+rEAD_PREC_Name = mkModuleName "Text.ParserCombinators.ReadPrec"
+lEX_Name = mkModuleName "Text.Read.Lex"
+
mAIN_Name = mkModuleName "Main"
pREL_INT_Name = mkModuleName "GHC.Int"
pREL_WORD_Name = mkModuleName "GHC.Word"
-- Class Monad
monadClassName = clsQual pREL_BASE_Name FSLIT("Monad") monadClassKey
-thenMName = varQual pREL_BASE_Name FSLIT(">>=") thenMClassOpKey
+thenMName = varQual pREL_BASE_Name FSLIT(">>") thenMClassOpKey
+bindMName = varQual pREL_BASE_Name FSLIT(">>=") bindMClassOpKey
returnMName = varQual pREL_BASE_Name FSLIT("return") returnMClassOpKey
failMName = varQual pREL_BASE_Name FSLIT("fail") failMClassOpKey
-- IOBase things
ioTyConName = tcQual pREL_IO_BASE_Name FSLIT("IO") ioTyConKey
ioDataConName = dataQual pREL_IO_BASE_Name FSLIT("IO") ioDataConKey
+thenIOName = varQual pREL_IO_BASE_Name FSLIT("thenIO") thenIOIdKey
bindIOName = varQual pREL_IO_BASE_Name FSLIT("bindIO") bindIOIdKey
returnIOName = varQual pREL_IO_BASE_Name FSLIT("returnIO") returnIOIdKey
failIOName = varQual pREL_IO_BASE_Name FSLIT("failIO") failIOIdKey
showSpace_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showSpace")
showString_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showString")
showParen_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showParen")
+
readsPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readsPrec")
+readPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readPrec")
+readListPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrec")
readList_RDR = varQual_RDR pREL_READ_Name FSLIT("readList")
-readParen_RDR = varQual_RDR pREL_READ_Name FSLIT("readParen")
-lex_RDR = varQual_RDR pREL_READ_Name FSLIT("lex")
-readList___RDR = varQual_RDR pREL_READ_Name FSLIT("readList__")
+
+readListDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListDefault")
+readListPrecDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrecDefault")
+parens_RDR = varQual_RDR pREL_READ_Name FSLIT("parens")
+choose_RDR = varQual_RDR pREL_READ_Name FSLIT("choose")
+lexP_RDR = varQual_RDR pREL_READ_Name FSLIT("lexP")
+
+-- Module ReadPrec
+step_RDR = varQual_RDR rEAD_PREC_Name FSLIT("step")
+reset_RDR = varQual_RDR rEAD_PREC_Name FSLIT("reset")
+alt_RDR = varQual_RDR rEAD_PREC_Name FSLIT("+++")
+prec_RDR = varQual_RDR rEAD_PREC_Name FSLIT("prec")
+
+-- Module Lex
+symbol_RDR = dataQual_RDR lEX_Name FSLIT("Symbol")
+ident_RDR = dataQual_RDR lEX_Name FSLIT("Ident")
+single_RDR = dataQual_RDR lEX_Name FSLIT("Single")
+
times_RDR = varQual_RDR pREL_NUM_Name FSLIT("*")
plus_RDR = varQual_RDR pREL_NUM_Name FSLIT("+")
negate_RDR = varQual_RDR pREL_NUM_Name FSLIT("negate")
build_RDR = nameRdrName buildName
enumFromTo_RDR = nameRdrName enumFromToName
returnM_RDR = nameRdrName returnMName
-thenM_RDR = nameRdrName thenMName
+bindM_RDR = nameRdrName bindMName
failM_RDR = nameRdrName failMName
false_RDR = nameRdrName falseDataConName
true_RDR = nameRdrName trueDataConName
eqStringIdKey = mkPreludeMiscIdUnique 16
noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 17
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18
-errorCStringIdKey = mkPreludeMiscIdUnique 19
+runtimeErrorIdKey = mkPreludeMiscIdUnique 19
parErrorIdKey = mkPreludeMiscIdUnique 20
parIdKey = mkPreludeMiscIdUnique 21
patErrorIdKey = mkPreludeMiscIdUnique 22
andIdKey = mkPreludeMiscIdUnique 57
orIdKey = mkPreludeMiscIdUnique 58
+thenIOIdKey = mkPreludeMiscIdUnique 59
-- Parallel array functions
nullPIdKey = mkPreludeMiscIdUnique 70
geClassOpKey = mkPreludeMiscIdUnique 110
negateClassOpKey = mkPreludeMiscIdUnique 111
failMClassOpKey = mkPreludeMiscIdUnique 112
-thenMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
+bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
+thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>)
fromEnumClassOpKey = mkPreludeMiscIdUnique 115
returnMClassOpKey = mkPreludeMiscIdUnique 117
toEnumClassOpKey = mkPreludeMiscIdUnique 119
deriving_occ_info
= [ (eqClassKey, [intTyCon_RDR, and_RDR, not_RDR])
- , (ordClassKey, [intTyCon_RDR, compose_RDR, eqTag_RDR])
+ , (ordClassKey, [intTyCon_RDR, compose_RDR, eqTag_RDR, error_RDR])
-- EQ (from Ordering) is needed to force in the constructors
-- as well as the type constructor.
- , (enumClassKey, [intTyCon_RDR, eq_RDR, ge_RDR, and_RDR, map_RDR, plus_RDR, showsPrec_RDR, append_RDR])
+ , (enumClassKey, [intTyCon_RDR, eq_RDR, ge_RDR, and_RDR, map_RDR, plus_RDR,
+ error_RDR, showsPrec_RDR, append_RDR])
-- The last two Enum deps are only used to produce better
-- error msgs for derived toEnum methods.
, (boundedClassKey, [intTyCon_RDR])
, (showClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR,
showParen_RDR, showSpace_RDR, showList___RDR])
- , (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, append_RDR,
- foldr_RDR, build_RDR,
- -- foldr and build required for list comprehension
- -- KSW 2000-06
- lex_RDR, readParen_RDR, readList___RDR, thenM_RDR])
- -- returnM (and the rest of the Monad class decl)
- -- will be forced in as result of depending
- -- on thenM. -- SOF 1/99
- , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR, enumFromTo_RDR,
- foldr_RDR, build_RDR,
+ , (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR,
+ lexP_RDR, readPrec_RDR,
+ readListDefault_RDR, readListPrecDefault_RDR,
+ step_RDR, parens_RDR, reset_RDR, prec_RDR, alt_RDR, choose_RDR,
+ ident_RDR, -- Pulls in the entire Lex.Lexeme data type
+ bindM_RDR -- Pulls in the entire Monad class decl
+ ] )
+ , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR, enumFromTo_RDR, error_RDR,
+ foldr_RDR, build_RDR,
-- foldr and build required for list comprehension used
-- with single constructor types -- KSW 2000-06
returnM_RDR, failM_RDR])
-> Module
-> RdrNameHsModule
-> IO (PersistentCompilerState, PrintUnqualified,
- Maybe (IsExported, ModIface, RnResult))
+ Maybe (IsExported, ModIface, [RenamedHsDecl]))
-- Nothing => some error occurred in the renamer
renameExtCore dflags hit hst pcs this_module
- rdr_module@(HsModule _ _ exports imports local_decls mod_deprec loc)
+ rdr_module@(HsModule _ _ _ _ local_decls _ loc)
-- Rename the (Core) module
= renameSource dflags hit hst pcs this_module $
pushSrcLocRn loc $
- -- RENAME THE SOURCE
- rnSourceDecls emptyRdrEnv emptyAvailEnv
- emptyLocalFixityEnv
- InterfaceMode local_decls `thenRn` \ (rn_local_decls, source_fvs) ->
- let
- tycl_decls = [d | (TyClD d) <- rn_local_decls ]
- local_names = foldl add emptyNameSet tycl_decls
- add names decl = addListToNameSet names (map fst (tyClDeclSysNames decl ++ tyClDeclNames decl))
- in
- recordLocalSlurps local_names `thenRn_`
- closeDecls rn_local_decls source_fvs `thenRn` \ final_decls ->
- -- print everything qualified.
- let print_unqualified = const False in
+ -- Rename the source
+ initIfaceRnMS this_module (rnExtCoreDecls local_decls) `thenRn` \ (rn_local_decls, binders, fvs) ->
+ recordLocalSlurps binders `thenRn_`
+ closeDecls rn_local_decls fvs `thenRn` \ final_decls ->
+
-- Bail out if we fail
checkErrsRn `thenRn` \ no_errs_so_far ->
if not no_errs_so_far then
returnRn (print_unqualified, Nothing)
else
- let
+ rnDump final_decls [] `thenRn_`
+ let
mod_iface = ModIface { mi_module = this_module,
mi_package = opt_InPackage,
mi_version = initialVersionInfo,
mi_usages = [],
mi_boot = False,
mi_orphan = panic "is_orphan",
- mi_exports = [],
+ -- ToDo: export the data types also.
+ mi_exports = [(moduleName this_module,
+ map Avail (nameSetToList binders))],
mi_globals = Nothing,
mi_fixities = mkNameEnv [],
mi_deprecs = NoDeprecs,
mi_decls = panic "mi_decls"
}
- rn_result = RnResult { rr_mod = this_module,
- rr_fixities = mkNameEnv [],
- rr_decls = final_decls,
- rr_main = Nothing }
-
is_exported _ = True
in
- returnRn (print_unqualified, Just (is_exported, mod_iface, rn_result))
+ returnRn (print_unqualified, Just (is_exported, mod_iface, final_decls))
+
+ where
+ print_unqualified = const False -- print everything qualified.
+
+
+rnExtCoreDecls :: [RdrNameHsDecl]
+ -> RnMS ([RenamedHsDecl],
+ NameSet, -- Binders
+ FreeVars) -- Free variables
+
+rnExtCoreDecls decls
+ -- Renaming external-core decls is rather like renaming an interface file
+ -- All the decls are TyClDecls, and all the names are original names
+ = go [] emptyNameSet emptyNameSet decls
+ where
+ go rn_decls bndrs fvs [] = returnRn (rn_decls, bndrs, fvs)
+
+ go rn_decls bndrs fvs (TyClD decl : decls)
+ = rnTyClDecl decl `thenRn` \ rn_decl ->
+ go (TyClD rn_decl : rn_decls)
+ (addListToNameSet bndrs (map fst (tyClDeclSysNames rn_decl ++ tyClDeclNames rn_decl)))
+ (fvs `plusFV` tyClDeclFVs rn_decl)
+ decls
+
+ go rn_decls bndrs fvs (decl : decls)
+ = addErrRn (text "Unexpected decl in ExtCore file" $$ ppr decl) `thenRn_`
+ go rn_decls bndrs fvs decls
\end{code}
import TysWiredIn ( intTyCon )
import Name ( NamedThing(..), mkSystemName, nameSrcLoc )
import NameSet
+import UnicodeUtil ( stringToUtf8 )
import UniqFM ( isNullUFM )
import UniqSet ( emptyUniqSet )
import List ( intersectBy )
let
expr =
HsApp (HsVar name)
- (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
-
+ (HsLit (HsStringPrim (_PK_ (stringToUtf8 (showSDoc (ppr sloc))))))
in
returnRn (expr, unitFV name)
-
\end{code}
%************************************************************************
-------------------------------------------------------
-- closeDecls keeps going until the free-var set is empty
closeDecls decls needed
- | not (isEmptyFVs needed)
- = slurpDecls decls needed `thenRn` \ (decls1, needed1) ->
- closeDecls decls1 needed1
-
- | otherwise
- = getImportedRules `thenRn` \ rule_decls ->
+ = slurpIfaceDecls decls needed `thenRn` \ decls1 ->
+ getImportedRules `thenRn` \ rule_decls ->
case rule_decls of
- [] -> returnRn decls -- No new rules, so we are done
+ [] -> returnRn decls1 -- No new rules, so we are done
other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenRn` \ rule_decls' ->
let
rule_fvs = plusFVs (map ruleDeclFVs rule_decls')
in
- traceRn (text "closeRules" <+> ppr rule_decls' $$ fsep (map ppr (nameSetToList rule_fvs))) `thenRn_`
- closeDecls (map RuleD rule_decls' ++ decls) rule_fvs
-
+ traceRn (text "closeRules" <+> ppr rule_decls' $$
+ fsep (map ppr (nameSetToList rule_fvs))) `thenRn_`
+ closeDecls (map RuleD rule_decls' ++ decls1) rule_fvs
-------------------------------------------------------
--- Augment decls with any decls needed by needed.
--- Return also free vars of the new decls (only)
-slurpDecls decls needed
- = go decls emptyFVs (nameSetToList needed)
+-- Augment decls with any decls needed by needed,
+-- and so on transitively
+slurpIfaceDecls :: [RenamedHsDecl] -> FreeVars -> RnMG [RenamedHsDecl]
+slurpIfaceDecls decls needed
+ = slurp decls (nameSetToList needed)
where
- go decls fvs [] = returnRn (decls, fvs)
- go decls fvs (ref:refs) = slurpDecl decls fvs ref `thenRn` \ (decls1, fvs1) ->
- go decls1 fvs1 refs
-
--------------------------------------------------------
-slurpDecl decls fvs wanted_name
- = importDecl wanted_name `thenRn` \ import_result ->
- case import_result of
- -- Found a declaration... rename it
- HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
- returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs)
-
- -- No declaration... (wired in thing, or deferred, or already slurped)
- other -> returnRn (decls, fvs)
+ slurp decls [] = returnRn decls
+ slurp decls (n:ns) = slurp_one decls n `thenRn` \ decls1 ->
+ slurp decls1 ns
+
+ slurp_one decls wanted_name
+ = importDecl wanted_name `thenRn` \ import_result ->
+ case import_result of
+ HereItIs decl -> -- Found a declaration... rename it
+ -- and get the things it needs
+ rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs) ->
+ slurp (TyClD new_decl : decls) (nameSetToList fvs)
+
+
+ other -> -- No declaration... (wired in thing, or deferred,
+ -- or already slurped)
+ returnRn decls
-------------------------------------------------------
)
import CoreSyn
import CoreUtils ( cheapEqExpr, exprType,
- etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
+ etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
findDefault, exprOkForSpeculation, exprIsValue
)
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-- re_note wraps a coerce if it might be necessary
re_note scrut = case head alts of
- (_,_,rhs1@(Note _ _)) -> mkCoerce (exprType rhs1) (idType case_bndr) scrut
+ (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut
other -> scrut
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsValue,
exprOkForSpeculation, exprArity,
- mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
+ mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
-- But it isn't a common case.
= let
(t1,t2) = splitFunTy t1t2
- new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
+ new_arg = mkCoerce2 s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
in
ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
rebuild env expr (Stop _ _ _) = rebuildDone env expr
rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr
-rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
+rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty expr) cont
rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont
rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont
-- fw = \ab -> (__inline (\x -> E)) (a,b)
-- and the original __inline now vanishes, so E is no longer
-- inside its __inline wrapper. Death! Disaster!
- = returnUs [ (fn_id', rhs) ]
+ = returnUs [ (new_fn_id, rhs) ]
| is_thunk && worthSplittingThunk maybe_fn_dmd res_info
- = ASSERT( isNonRec is_rec ) -- The thunk must be non-recursive
- splitThunk fn_id' rhs
+ = ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive
+ splitThunk new_fn_id rhs
| is_fun && worthSplittingFun wrap_dmds res_info
- = splitFun fn_id' fn_info wrap_dmds res_info inline_prag rhs
+ = splitFun new_fn_id fn_info wrap_dmds res_info inline_prag rhs
| otherwise
- = returnUs [ (fn_id', rhs) ]
+ = returnUs [ (new_fn_id, rhs) ]
where
fn_info = idInfo fn_id
strict_sig = newStrictnessInfo fn_info `orElse` topSig
StrictSig (DmdType env wrap_dmds res_info) = strict_sig
- -- fn_id' has the DmdEnv zapped.
+ -- new_fn_id has the DmdEnv zapped.
-- (a) it is never used again
-- (b) it wastes space
-- (c) it becomes incorrect as things are cloned, because
-- we don't push the substitution into it
- fn_id' | isEmptyVarEnv env = fn_id
- | otherwise = fn_id `setIdNewStrictness`
- StrictSig (mkTopDmdType wrap_dmds res_info)
+ new_fn_id | isEmptyVarEnv env = fn_id
+ | otherwise = fn_id `setIdNewStrictness`
+ StrictSig (mkTopDmdType wrap_dmds res_info)
is_fun = notNull wrap_dmds
is_thunk = not is_fun && not (exprIsValue rhs)
import IdInfo ( vanillaIdInfo )
import DataCon ( splitProductType_maybe, splitProductType )
import NewDemand ( Demand(..), DmdResult(..), Demands(..) )
-import MkId ( realWorldPrimId, voidArgId, eRROR_CSTRING_ID )
+import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID )
import TysWiredIn ( tupleCon )
import Type ( Type, isUnLiftedType, mkFunTys,
splitForAllTys, splitFunTys, splitNewType_maybe, isAlgType
= panic "WwLib: haven't done mk_absent_let for primitives yet"
where
arg_ty = idType arg
--- abs_rhs = mkTyApps (Var aBSENT_ERROR_ID) [arg_ty]
- abs_rhs = mkApps (Var eRROR_CSTRING_ID) [Type arg_ty, Lit (MachStr (_PK_ msg))]
+ abs_rhs = mkRuntimeErrorApp rUNTIME_ERROR_ID arg_ty msg
msg = "Oops! Entered absent arg " ++ showSDocDebug (ppr arg <+> ppr (idType arg))
mk_unpk_case arg unpk_args boxing_con boxing_tycon body
pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
newDictsFromOld, newDicts, cloneDict,
- newMethod, newMethodWithGivenTy, newMethodAtLoc,
+ newMethod, newMethodFromName, newMethodWithGivenTy, newMethodAtLoc,
newOverloadedLit, newIPDict, tcInstCall, tcInstDataCon,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
)
import TcMonad
-import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupId )
+import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupId, tcLookupGlobalId )
import InstEnv ( InstLookupResult(..), lookupInstEnv )
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
mkLIE stupid_dicts, mkLIE ex_dicts, ex_tvs')
+newMethodFromName :: InstOrigin -> TcType -> Name -> NF_TcM Inst
+newMethodFromName origin ty name
+ = tcLookupGlobalId name `thenNF_Tc` \ id ->
+ newMethod origin id [ty]
+
newMethod :: InstOrigin
-> TcId
-> [TcType]
import Outputable
import Var ( TyVar )
import CmdLineOpts
+import UnicodeUtil ( stringToUtf8 )
import ErrUtils ( dumpIfSet )
import Util ( count, lengthIs, equalLength )
import Maybes ( seqMaybe )
returnTc error_rhs
where
error_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
- (HsLit (HsString (_PK_ error_msg)))
+ (HsLit (HsStringPrim (_PK_ (stringToUtf8 error_msg))))
error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
where
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
ddump_deriving inst_infos extra_binds
- = vcat (map pprInstInfo inst_infos) $$ ppr extra_binds
+ = vcat (map ppr_info inst_infos) $$ ppr extra_binds
+ ppr_info inst_info = pprInstInfo inst_info $$
+ nest 4 (ppr (iBinds inst_info))
+ -- pprInstInfo doesn't print much: only the type
-----------------------------------------
deriveOrdinaryStuff mod prs inst_env_in get_fixity [] -- Short cut
import BasicTypes ( RecFlag(..), isMarkedStrict )
import Inst ( InstOrigin(..),
LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
- newOverloadedLit, newMethod, newIPDict,
+ newOverloadedLit, newMethodFromName, newIPDict,
newDicts, newMethodWithGivenTy,
instToId, tcInstCall, tcInstDataCon
)
enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName,
- thenMName, failMName, returnMName, ioTyConName
+ thenMName, bindMName, failMName, returnMName, ioTyConName
)
import Outputable
import ListSetOps ( minusList )
= unifyListTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
- tcLookupGlobalId enumFromName `thenNF_Tc` \ sel_id ->
- newMethod (ArithSeqOrigin seq)
- sel_id [elt_ty] `thenNF_Tc` \ enum_from ->
+ newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromName `thenNF_Tc` \ enum_from ->
returnTc (ArithSeqOut (HsVar (instToId enum_from)) (From expr'),
lie1 `plusLIE` unitLIE enum_from)
unifyListTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
- tcLookupGlobalId enumFromThenName `thenNF_Tc` \ sel_id ->
- newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ enum_from_then ->
+ newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromThenName `thenNF_Tc` \ enum_from_then ->
returnTc (ArithSeqOut (HsVar (instToId enum_from_then))
(FromThen expr1' expr2'),
unifyListTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
- tcLookupGlobalId enumFromToName `thenNF_Tc` \ sel_id ->
- newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ enum_from_to ->
+ newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromToName `thenNF_Tc` \ enum_from_to ->
returnTc (ArithSeqOut (HsVar (instToId enum_from_to))
(FromTo expr1' expr2'),
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
- tcLookupGlobalId enumFromThenToName `thenNF_Tc` \ sel_id ->
- newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ eft ->
+ newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromThenToName `thenNF_Tc` \ eft ->
returnTc (ArithSeqOut (HsVar (instToId eft))
(FromThenTo expr1' expr2' expr3'),
unifyPArrTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
- tcLookupGlobalId enumFromToPName `thenNF_Tc` \ sel_id ->
- newMethod (PArrSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ enum_from_to ->
+ newMethodFromName (PArrSeqOrigin seq)
+ elt_ty enumFromToPName `thenNF_Tc` \ enum_from_to ->
returnTc (PArrSeqOut (HsVar (instToId enum_from_to))
(FromTo expr1' expr2'),
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
- tcLookupGlobalId enumFromThenToPName `thenNF_Tc` \ sel_id ->
- newMethod (PArrSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ eft ->
+ newMethodFromName (PArrSeqOrigin seq)
+ elt_ty enumFromThenToPName `thenNF_Tc` \ eft ->
returnTc (PArrSeqOut (HsVar (instToId eft))
(FromThenTo expr1' expr2' expr3'),
in
tcStmts (DoCtxt PArrComp) m_ty stmts `thenTc` \(stmts', stmts_lie) ->
returnTc (HsDoOut PArrComp stmts'
- undefined undefined undefined -- don't touch!
+ undefined -- don't touch!
res_ty src_loc,
stmts_lie)
-- then = then
-- where the second "then" sees that it already exists in the "available" stuff.
--
- tcLookupGlobalId returnMName `thenNF_Tc` \ return_sel_id ->
- tcLookupGlobalId thenMName `thenNF_Tc` \ then_sel_id ->
- tcLookupGlobalId failMName `thenNF_Tc` \ fail_sel_id ->
- newMethod DoOrigin return_sel_id [tc_ty] `thenNF_Tc` \ return_inst ->
- newMethod DoOrigin then_sel_id [tc_ty] `thenNF_Tc` \ then_inst ->
- newMethod DoOrigin fail_sel_id [tc_ty] `thenNF_Tc` \ fail_inst ->
- let
- monad_lie = mkLIE [return_inst, then_inst, fail_inst]
- in
+ mapNF_Tc (newMethodFromName DoOrigin tc_ty)
+ [returnMName, failMName, bindMName, thenMName] `thenNF_Tc` \ insts ->
+
returnTc (HsDoOut do_or_lc stmts'
- (instToId return_inst) (instToId then_inst) (instToId fail_inst)
+ (map instToId insts)
res_ty src_loc,
- stmts_lie `plusLIE` monad_lie)
+ stmts_lie `plusLIE` mkLIE insts)
\end{code}
, maxPrecedence
, Boxity(..)
)
-import FieldLabel ( fieldLabelName )
+import FieldLabel ( FieldLabel, fieldLabelName )
import DataCon ( isNullaryDataCon, dataConTag,
dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
DataCon,
zipWith3Equal, nOfThem )
import Panic ( panic, assertPanic )
import Maybes ( maybeToBool )
+import Char ( ord )
import Constants
import List ( partition, intersperse )
\end{code}
mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
`AndMonoBinds`
mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
- HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
+ HsApp (HsVar not_RDR) (HsPar (mkHsVarApps eq_RDR [a_RDR, b_RDR])))
where
------------------------------------------------------------------
pats_etc data_con
succ_enum
= mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
- HsIf (HsApp (HsApp (HsVar eq_RDR)
- (HsVar (maxtag_RDR tycon)))
- (mk_easy_App mkInt_RDR [ah_RDR]))
+ HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon),
+ mkHsVarApps mkInt_RDR [ah_RDR]])
(illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
(HsApp (HsVar (tag2con_RDR tycon))
- (HsApp (HsApp (HsVar plus_RDR)
- (mk_easy_App mkInt_RDR [ah_RDR]))
- (HsLit (HsInt 1))))
+ (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
+ mkHsIntLit 1]))
tycon_loc
pred_enum
= mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
- HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
- (mk_easy_App mkInt_RDR [ah_RDR]))
+ HsIf (mkHsApps eq_RDR [mkHsIntLit 0,
+ mkHsVarApps mkInt_RDR [ah_RDR]])
(illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
(HsApp (HsVar (tag2con_RDR tycon))
- (HsApp (HsApp (HsVar plus_RDR)
- (mk_easy_App mkInt_RDR [ah_RDR]))
- (HsLit (HsInt (-1)))))
+ (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
+ HsLit (HsInt (-1))]))
tycon_loc
to_enum
= mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
- HsIf (HsApp (HsApp
- (HsVar and_RDR)
- (HsApp (HsApp (HsVar ge_RDR)
- (HsVar a_RDR))
- (HsLit (HsInt 0))))
- (HsApp (HsApp (HsVar le_RDR)
- (HsVar a_RDR))
- (HsVar (maxtag_RDR tycon))))
- (mk_easy_App (tag2con_RDR tycon) [a_RDR])
+ HsIf (mkHsApps and_RDR
+ [mkHsApps ge_RDR [HsVar a_RDR, mkHsIntLit 0],
+ mkHsApps le_RDR [HsVar a_RDR, HsVar (maxtag_RDR tycon)]])
+ (mkHsVarApps (tag2con_RDR tycon) [a_RDR])
(illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
tycon_loc
enum_from
= mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
- HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
- HsPar (enum_from_to_Expr
- (mk_easy_App mkInt_RDR [ah_RDR])
- (HsVar (maxtag_RDR tycon)))
+ mkHsApps map_RDR
+ [HsVar (tag2con_RDR tycon),
+ HsPar (enum_from_to_Expr
+ (mkHsVarApps mkInt_RDR [ah_RDR])
+ (HsVar (maxtag_RDR tycon)))]
enum_from_then
= mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
- HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
+ HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
HsPar (enum_from_then_to_Expr
- (mk_easy_App mkInt_RDR [ah_RDR])
- (mk_easy_App mkInt_RDR [bh_RDR])
- (HsIf (HsApp (HsApp (HsVar gt_RDR)
- (mk_easy_App mkInt_RDR [ah_RDR]))
- (mk_easy_App mkInt_RDR [bh_RDR]))
- (HsLit (HsInt 0))
+ (mkHsVarApps mkInt_RDR [ah_RDR])
+ (mkHsVarApps mkInt_RDR [bh_RDR])
+ (HsIf (mkHsApps gt_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
+ mkHsVarApps mkInt_RDR [bh_RDR]])
+ (mkHsIntLit 0)
(HsVar (maxtag_RDR tycon))
tycon_loc))
from_enum
= mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
- (mk_easy_App mkInt_RDR [ah_RDR])
+ (mkHsVarApps mkInt_RDR [ah_RDR])
\end{code}
%************************************************************************
arity = dataConSourceArity data_con_1
min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
- mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
+ mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
- mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
+ mkHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
\end{code}
%************************************************************************
[TuplePatIn [a_Pat, b_Pat] Boxed] [] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
untag_Expr tycon [(b_RDR, bh_RDR)] $
- HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
+ HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
HsPar (enum_from_to_Expr
- (mk_easy_App mkInt_RDR [ah_RDR])
- (mk_easy_App mkInt_RDR [bh_RDR]))
+ (mkHsVarApps mkInt_RDR [ah_RDR])
+ (mkHsVarApps mkInt_RDR [bh_RDR]))
enum_index
= mk_easy_FunMonoBind tycon_loc index_RDR
[AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed),
d_Pat] [] (
- HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
+ HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] (
let
- rhs = mk_easy_App mkInt_RDR [c_RDR]
+ rhs = mkHsVarApps mkInt_RDR [c_RDR]
in
HsCase
(genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
cs_needed = take con_arity cs_RDRs
con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
- con_expr = mk_easy_App data_con_RDR cs_needed
+ con_expr = mkHsVarApps data_con_RDR cs_needed
--------------------------------------------------------------
single_con_range
= mk_easy_FunMonoBind tycon_loc index_RDR
[TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed] [range_size] (
- foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
+ foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
where
mk_index multiply_by (l, u, i)
= genOpApp (
- (HsApp (HsApp (HsVar index_RDR)
- (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i))
+ (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed,
+ HsVar i])
) plus_RDR (
genOpApp (
(HsApp (HsVar rangeSize_RDR)
= mk_easy_FunMonoBind tycon_loc rangeSize_RDR
[TuplePatIn [a_Pat, b_Pat] Boxed] [] (
genOpApp (
- (HsApp (HsApp (HsVar index_RDR)
- (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr)
- ) plus_RDR (HsLit (HsInt 1)))
+ (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
+ b_Expr])
+ ) plus_RDR (mkHsIntLit 1))
------------------
single_con_inRange
[] (
foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
where
- in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
- (ExplicitTuple [HsVar a, HsVar b] Boxed))
- (HsVar c)
+ in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed,
+ HsVar c]
\end{code}
%************************************************************************
%* *
%************************************************************************
+Example
+
+ infix 4 %%
+ data T = Int %% Int
+ | T1 { f1 :: Int }
+ | T2 Int
+
+
+instance Read T where
+ readPrec =
+ block
+ ( prec 4 (
+ do x <- ReadP.step Read.readPrec
+ Symbol "%%" <- Lex.lex
+ y <- ReadP.step Read.readPrec
+ return (x %% y))
+ +++
+ prec appPrec (
+ do Ident "T1" <- Lex.lex
+ Single '{' <- Lex.lex
+ Ident "f1" <- Lex.lex
+ Single '=' <- Lex.lex
+ x <- ReadP.reset Read.readPrec
+ Single '}' <- Lex.lex
+ return (T1 { f1 = x }))
+ +++
+ prec appPrec (
+ do Ident "T2" <- Lex.lexP
+ x <- ReadP.step Read.readPrec
+ return (T2 x))
+ )
+
+ readListPrec = readListPrecDefault
+ readList = readListDefault
+
+
\begin{code}
gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
gen_Read_binds get_fixity tycon
- = reads_prec `AndMonoBinds` read_list
+ = read_prec `AndMonoBinds` default_binds
where
- tycon_loc = getSrcLoc tycon
-----------------------------------------------------------------------
- read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
- (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
+ default_binds
+ = mk_easy_FunMonoBind loc readList_RDR [] [] (HsVar readListDefault_RDR)
+ `AndMonoBinds`
+ mk_easy_FunMonoBind loc readListPrec_RDR [] [] (HsVar readListPrecDefault_RDR)
-----------------------------------------------------------------------
- reads_prec
- = let
- read_con_comprehensions
- = map read_con (tyConDataCons tycon)
- in
- mk_easy_FunMonoBind tycon_loc readsPrec_RDR [zz_a_Pat, b_Pat] [] (
- foldr1 append_Expr read_con_comprehensions
- )
+
+ loc = getSrcLoc tycon
+ data_cons = tyConDataCons tycon
+ (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
+
+ read_prec = mk_easy_FunMonoBind loc readPrec_RDR [] []
+ (HsApp (HsVar parens_RDR) read_cons)
+
+ read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
+ read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
+
+ read_nullary_cons
+ = case nullary_cons of
+ [] -> []
+ [con] -> [HsDo DoExpr [BindStmt (ident_pat (data_con_str con)) lex loc,
+ result_stmt con []] loc]
+ _ -> [HsApp (HsVar choose_RDR)
+ (ExplicitList placeHolderType (map mk_pair nullary_cons))]
+
+ mk_pair con = ExplicitTuple [HsLit (data_con_str con),
+ HsApp (HsVar returnM_RDR) (HsVar (qual_orig_name con))]
+ Boxed
+
+ read_non_nullary_con data_con
+ = mkHsApps prec_RDR [mkHsIntLit prec, HsDo DoExpr stmts loc]
where
- read_con data_con -- note: "b" is the string being "read"
- = HsApp (
- readParen_Expr read_paren_arg $ HsPar $
- HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
- HsDo ListComp stmts tycon_loc)
- ) (HsVar b_RDR)
- where
- data_con_RDR = qual_orig_name data_con
- data_con_str = occNameUserString (getOccName data_con)
- con_arity = dataConSourceArity data_con
- con_expr = mk_easy_App data_con_RDR as_needed
- nullary_con = con_arity == 0
- labels = dataConFieldLabels data_con
- lab_fields = length labels
- dc_nm = getName data_con
- is_infix = isDataSymOcc (getOccName dc_nm)
-
- as_needed = take con_arity as_RDRs
- bs_needed
- | is_infix = take (1 + con_arity) bs_RDRs
- | lab_fields == 0 = take con_arity bs_RDRs
- | otherwise = take (4*lab_fields + 1) bs_RDRs
- -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
-
- (as1:as2:_) = as_needed
- (bs1:bs2:bs3:_) = bs_needed
-
- con_qual
- | not is_infix =
- BindStmt
- (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed)
- (HsApp (HsVar lex_RDR) c_Expr)
- tycon_loc
- | otherwise =
- BindStmt
- (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed)
- (HsApp (HsVar lex_RDR) (HsVar bs1))
- tycon_loc
-
-
- str_qual str res draw_from =
- BindStmt
- (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
- (HsApp (HsVar lex_RDR) draw_from)
- tycon_loc
-
- str_qual_paren str res draw_from =
- BindStmt
- (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
- (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
- tycon_loc
-
- read_label f = [rd_lab, str_qual "="]
- -- There might be spaces between the label and '='
- where
- rd_lab
- | is_op = str_qual_paren nm
- | otherwise = str_qual nm
-
- occ_nm = getOccName (fieldLabelName f)
- is_op = isSymOcc occ_nm
- nm = occNameUserString occ_nm
-
- field_quals
- | is_infix =
- snd (mapAccumL mk_qual_infix
- c_Expr
- [ (mk_read_qual lp as1, bs1, bs2)
- , (mk_read_qual rp as2, bs3, bs3)
- ])
- | lab_fields == 0 = -- common case.
- snd (mapAccumL mk_qual
- d_Expr
- (zipWithEqual "as_needed"
- (\ con_field draw_from -> (mk_read_qual 10 con_field,
- draw_from))
- as_needed bs_needed))
- | otherwise =
- snd $
- mapAccumL mk_qual d_Expr
- (zipEqual "bs_needed"
- ((str_qual "{":
- concat (
- intersperse [str_qual ","] $
- zipWithEqual
- "field_quals"
- (\ as b -> as ++ [b])
- -- The labels
- (map read_label labels)
- -- The fields
- (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
- bs_needed)
-
- mk_qual_infix draw_from (f, str_left, str_left2) =
- (HsVar str_left2, -- what to draw from down the line...
- f str_left draw_from)
-
- mk_qual draw_from (f, str_left) =
- (HsVar str_left, -- what to draw from down the line...
- f str_left draw_from)
-
- mk_read_qual p con_field res draw_from =
- BindStmt
- (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed)
- (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
- tycon_loc
-
- result_expr = ExplicitTuple [con_expr, if null bs_needed
- then d_Expr
- else HsVar (last bs_needed)] Boxed
-
- [lp,rp] = getLRPrecs is_infix get_fixity dc_nm
-
- quals
- | is_infix = let (h:t) = field_quals in (h:con_qual:t)
- | otherwise = con_qual:field_quals
-
- stmts = quals ++ [ResultStmt result_expr tycon_loc]
-
- {-
- c.f. Figure 18 in Haskell 1.1 report.
- -}
- paren_prec_limit
- | not is_infix = defaultPrecedence
- | otherwise = getPrecedence get_fixity dc_nm
-
- read_paren_arg -- parens depend on precedence...
- | nullary_con = false_Expr -- it's optional.
- | otherwise = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
+ stmts | is_infix = infix_stmts
+ | length labels > 0 = lbl_stmts
+ | otherwise = prefix_stmts
+
+ prefix_stmts -- T a b c
+ = [BindStmt (ident_pat (data_con_str data_con)) lex loc]
+ ++ map read_arg as_needed
+ ++ [result_stmt data_con as_needed]
+
+ infix_stmts -- a %% b
+ = [read_arg a1,
+ BindStmt (symbol_pat (data_con_str data_con)) lex loc,
+ read_arg a2,
+ result_stmt data_con [a1,a2]]
+
+ lbl_stmts -- T { f1 = a, f2 = b }
+ = [BindStmt (ident_pat (data_con_str data_con)) lex loc,
+ read_punc '{']
+ ++ concat (intersperse [read_punc ','] field_stmts)
+ ++ [read_punc '}', result_stmt data_con as_needed]
+
+ field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
+
+ con_arity = dataConSourceArity data_con
+ nullary_con = con_arity == 0
+ labels = dataConFieldLabels data_con
+ lab_fields = length labels
+ dc_nm = getName data_con
+ is_infix = isDataSymOcc (getOccName dc_nm)
+ as_needed = take con_arity as_RDRs
+ (a1:a2:_) = as_needed
+
+ prec | not is_infix = appPrecedence
+ | otherwise = getPrecedence get_fixity dc_nm
+
+ ------------------------------------------------------------------------
+ -- Helpers
+ ------------------------------------------------------------------------
+ mk_alt e1 e2 = genOpApp e1 alt_RDR e2
+ result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
+ con_app c as = mkHsVarApps (qual_orig_name c) as
+
+ lex = HsVar lexP_RDR
+ single_pat c = ConPatIn single_RDR [LitPatIn (mkHsChar c)] -- Single 'x'
+ ident_pat s = ConPatIn ident_RDR [LitPatIn s] -- Ident "foo"
+ symbol_pat s = ConPatIn symbol_RDR [LitPatIn s] -- Symbol ">>"
+
+ lbl_str :: FieldLabel -> HsLit
+ lbl_str lbl = mkHsString (occNameUserString (getOccName (fieldLabelName lbl)))
+ data_con_str con = mkHsString (occNameUserString (getOccName con))
+
+ read_punc c = BindStmt (single_pat c) lex loc
+ read_arg a = BindStmt (VarPatIn a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
+
+ read_field lbl a = [BindStmt (ident_pat (lbl_str lbl)) lex loc,
+ read_punc '=',
+ BindStmt (VarPatIn a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
\end{code}
+
%************************************************************************
%* *
\subsubsection{Generating @Show@ instance declarations}
tycon_loc = getSrcLoc tycon
-----------------------------------------------------------------------
show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
- (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
+ (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0))))
-----------------------------------------------------------------------
shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
where
real_show_thingies
| is_infix =
- [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
+ [ mkHsApps showsPrec_RDR [HsLit (HsInt p), HsVar b]
| (p,b) <- zip prec_cons bs_needed ]
| otherwise =
- [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
+ [ mkHsApps showsPrec_RDR [mkHsIntLit 10, HsVar b]
| b <- bs_needed ]
real_show_thingies_with_labs
c.f. Figure 16 and 17 in Haskell 1.1 report
-}
paren_prec_limit
- | not is_infix = defaultPrecedence + 1
+ | not is_infix = appPrecedence + 1
| otherwise = getPrecedence get_fixity dc_nm + 1
\end{code}
paren_con_prec = getPrecedence get_fixity nm
lp
- | not is_infix = defaultPrecedence + 1
+ | not is_infix = appPrecedence + 1
| con_left_assoc = paren_con_prec
| otherwise = paren_con_prec + 1
rp
- | not is_infix = defaultPrecedence + 1
+ | not is_infix = appPrecedence + 1
| con_right_assoc = paren_con_prec
| otherwise = paren_con_prec + 1
-defaultPrecedence :: Integer
-defaultPrecedence = fromIntegral maxPrecedence
+appPrecedence :: Integer
+appPrecedence = fromIntegral maxPrecedence
getPrecedence :: FixityEnv -> Name -> Integer
getPrecedence get_fixity nm
\end{code}
\begin{code}
-mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
+mkHsApps f xs = foldl HsApp (HsVar f) xs
+mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs)
+
+mkHsIntLit n = HsLit (HsInt n)
+mkHsString s = HsString (_PK_ s)
+mkHsChar c = HsChar (ord c)
\end{code}
ToDo: Better SrcLocs.
enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
-showParen_Expr, readParen_Expr
+showParen_Expr
:: RdrNameHsExpr -> RdrNameHsExpr
-> RdrNameHsExpr
showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
-readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
(HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
(HsApp (HsApp (HsApp
(HsVar showsPrec_RDR)
- (HsLit (HsInt 0)))
+ (mkHsIntLit 0))
(HsVar a_RDR))
(HsApp (HsApp
(HsVar append_RDR)
(HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
(HsApp (HsApp (HsApp
(HsVar showsPrec_RDR)
- (HsLit (HsInt 0)))
+ (mkHsIntLit 0))
(HsVar maxtag))
(HsLit (HsString (_PK_ ")")))))))
bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
-mkHsString s = HsString (_PK_ s)
-
zz_a_Expr = HsVar zz_a_RDR
a_Expr = HsVar a_RDR
b_Expr = HsVar b_RDR
TcId,
zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
- zonkForeignExports, zonkRules, zonkCoreExpr, zonkCoreBinds
+ zonkForeignExports, zonkRules
) where
#include "HsVersions.h"
type TypecheckedHsModule = HsModule Id TypecheckedPat
type TypecheckedForeignDecl = ForeignDecl Id
type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
-type TypecheckedCoreBind = (Id, Type, CoreExpr)
+type TypecheckedCoreBind = (Id, CoreExpr)
\end{code}
\begin{code}
zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
-zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
+zonkExpr (HsDoOut do_or_lc stmts ids ty src_loc)
= zonkStmts stmts `thenNF_Tc` \ new_stmts ->
- zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
- zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
- zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
- returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
- new_ty src_loc)
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkIdOcc ids `thenNF_Tc` \ new_ids ->
+ returnNF_Tc (HsDoOut do_or_lc new_stmts new_ids new_ty src_loc)
zonkExpr (ExplicitList ty exprs)
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
returnNF_Tc (IfaceRuleOut fun' rule)
\end{code}
-\begin{code}
-zonkCoreBinds :: [TypecheckedCoreBind] -> NF_TcM [TypecheckedCoreBind]
-zonkCoreBinds ls = mapNF_Tc zonkOne ls
- where
- zonkOne (i, t, e) =
- zonkIdOcc i `thenNF_Tc` \ i' ->
- zonkTcTypeToType t `thenNF_Tc` \ t' ->
- zonkCoreExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (i',t',e')
-
--- needed?
-zonkCoreExpr :: CoreExpr -> NF_TcM CoreExpr
-zonkCoreExpr e =
- case e of
- Var i ->
- zonkIdOcc i `thenNF_Tc` \ i' ->
- returnNF_Tc (Var i')
- Lit l -> returnNF_Tc (Lit l)
- App f arg ->
- zonkCoreExpr f `thenNF_Tc` \ f' ->
- zonkCoreExpr arg `thenNF_Tc` \ arg' ->
- returnNF_Tc (App f' arg')
- Lam b e ->
- zonkIdOcc b `thenNF_Tc` \ b' ->
- zonkCoreExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (Lam b' e')
- Case scrut n alts ->
- zonkCoreExpr scrut `thenNF_Tc` \ scrut' ->
- zonkIdOcc n `thenNF_Tc` \ n' ->
- mapNF_Tc zonkCoreAlt alts `thenNF_Tc` \ alts' ->
- returnNF_Tc (Case scrut' n' alts')
- Let b rhs ->
- zonkCoreBind b `thenNF_Tc` \ b' ->
- zonkCoreExpr rhs `thenNF_Tc` \ rhs' ->
- returnNF_Tc (Let b' rhs')
- Note note e ->
- zonkNote note `thenNF_Tc` \ note' ->
- zonkCoreExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (Note note' e')
- Type t ->
- zonkTcTypeToType t `thenNF_Tc` \ t' ->
- returnNF_Tc (Type t')
-
-zonkCoreBind :: CoreBind -> NF_TcM CoreBind
-zonkCoreBind (NonRec b e) =
- zonkIdOcc b `thenNF_Tc` \ b' ->
- zonkCoreExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (NonRec b' e')
-zonkCoreBind (Rec bs) =
- mapNF_Tc zonkIt bs `thenNF_Tc` \ bs' ->
- returnNF_Tc (Rec bs')
- where
- zonkIt (b,e) =
- zonkIdOcc b `thenNF_Tc` \ b' ->
- zonkCoreExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (b',e')
-
-
-zonkCoreAlt :: CoreAlt -> NF_TcM CoreAlt
-zonkCoreAlt (ac, bs, rhs) =
- mapNF_Tc zonkIdOcc bs `thenNF_Tc` \ bs' ->
- zonkCoreExpr rhs `thenNF_Tc` \ rhs' ->
- returnNF_Tc (ac, bs', rhs')
-
-zonkNote :: Note -> NF_TcM Note
-zonkNote n =
- case n of
- Coerce t f ->
- zonkTcTypeToType t `thenNF_Tc` \ t' ->
- zonkTcTypeToType f `thenNF_Tc` \ f' ->
- returnNF_Tc (Coerce t' f')
- _ -> returnNF_Tc n
-
-\end{code}
#include "HsVersions.h"
import HsSyn ( TyClDecl(..), HsTupCon(..) )
+import TcHsSyn ( TypecheckedCoreBind )
import TcMonad
import TcMonoType ( tcIfaceType )
import TcEnv ( RecTcEnv, tcExtendTyVarEnv,
\begin{code}
-tcCoreBinds :: [RenamedTyClDecl]
- -> TcM [(Id, Type, CoreExpr)]
-tcCoreBinds ls = mapTc tcOne ls
- where
- tcOne (CoreDecl { tcdName = nm, tcdType = ty, tcdRhs = rhs }) =
- tcVar nm `thenTc` \ i ->
- tcIfaceType ty `thenTc` \ ty' ->
- tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (i,ty',rhs')
-
+tcCoreBinds :: [RenamedTyClDecl] -> TcM [TypecheckedCoreBind]
+-- We don't assume the bindings are in dependency order
+-- So first build the environment, then check the RHSs
+tcCoreBinds ls = mapTc tcCoreBinder ls `thenTc` \ bndrs ->
+ tcExtendGlobalValEnv bndrs $
+ mapTc tcCoreBind ls
+
+tcCoreBinder (CoreDecl { tcdName = nm, tcdType = ty })
+ = tcIfaceType ty `thenTc` \ ty' ->
+ returnTc (mkLocalId nm ty')
+
+tcCoreBind (CoreDecl { tcdName = nm, tcdRhs = rhs })
+ = tcVar nm `thenTc` \ id ->
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ returnTc (id, rhs')
\end{code}
-
\begin{code}
ifaceSigCtxt sig_name
= hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
import Class ( Class, classBigSig )
import Var ( idName, idType )
import Id ( setIdLocalExported )
-import MkId ( mkDictFunId, unsafeCoerceId, eRROR_ID )
+import MkId ( mkDictFunId, unsafeCoerceId, rUNTIME_ERROR_ID )
import FunDeps ( checkInstFDs )
import Generics ( validGenericInstanceType )
import Module ( Module, foldModuleEnv )
import Unique ( Uniquable(..) )
import Util ( lengthExceeds, isSingleton )
import BasicTypes ( NewOrData(..) )
+import UnicodeUtil ( stringToUtf8 )
import ErrUtils ( dumpIfSet_dyn )
import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
assocElts, extendAssoc_C, equivClassesByUniq, minusList
-- emit an error message. This in turn means that we don't
-- mention the constructor, which doesn't exist for CCallable, CReturnable
-- Hardly beautiful, but only three extra lines.
- HsApp (TyApp (HsVar eRROR_ID) [idType this_dict_id])
- (HsLit (HsString msg))
+ HsApp (TyApp (HsVar rUNTIME_ERROR_ID) [idType this_dict_id])
+ (HsLit (HsStringPrim (_PK_ (stringToUtf8 msg))))
| otherwise -- The common case
= mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
-- than needing to be repeated here.
where
- msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
+ msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas)
dict_bind = VarMonoBind this_dict_id dict_rhs
meth_binds = andMonoBindList meth_binds_s
isSourceInstDecl, mkSimpleMatch, placeHolderType, isCoreDecl
)
import PrelNames ( ioTyConName, printName,
- returnIOName, bindIOName, failIOName, runMainName,
+ returnIOName, bindIOName, failIOName, thenIOName, runMainName,
dollarMainName, itName
)
import MkId ( unsafeCoerceId )
TypecheckedForeignDecl, TypecheckedRuleDecl,
TypecheckedCoreBind,
zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
- zonkExpr, zonkIdBndr, zonkCoreBinds
+ zonkExpr, zonkIdBndr
)
import Rename ( RnResult(..) )
tc_stmts names stmts
- = tcLookupGlobalId returnIOName `thenNF_Tc` \ return_id ->
- tcLookupGlobalId bindIOName `thenNF_Tc` \ bind_id ->
- tcLookupGlobalId failIOName `thenNF_Tc` \ fail_id ->
+ = mapNF_Tc tcLookupGlobalId
+ [returnIOName, failIOName, bindIOName, thenIOName] `thenNF_Tc` \ io_ids ->
tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
newTyVarTy liftedTypeKind `thenNF_Tc` \ res_ty ->
let
+ return_id = head io_ids -- Rather gruesome
+
io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty)
-- mk_return builds the expression
traceTc (text "tcs 4") `thenNF_Tc_`
returnTc (mkHsLet const_binds $
- HsDoOut DoExpr tc_stmts return_id bind_id fail_id
+ HsDoOut DoExpr tc_stmts io_ids
(mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
ids)
where
fixTc (\ ~(unf_env, _, _, _) ->
-- This fixTc follows the same general plan as tcImports,
-- which is better commented (below)
- tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
+ tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
tcExtendGlobalEnv tycl_things $
tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
tcExtendGlobalValEnv sig_ids $
-- tcImports recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
- traceTc (text "Tc1") `thenNF_Tc_`
- tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
- tcExtendGlobalEnv tycl_things $
+ traceTc (text "Tc1") `thenNF_Tc_`
+ tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
+ tcExtendGlobalEnv tycl_things $
-- Interface type signatures
-- We tie a knot so that the Ids read out of interfaces are in scope
-> HomeSymbolTable
-> ModIface -- Iface for this module (just module & fixities)
-> [RenamedHsDecl]
- -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedCoreBind]))
+ -> IO (Maybe (PersistentCompilerState, (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])))
typecheckCoreModule dflags pcs hst mod_iface decls
= do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
- (tcCoreDecls this_mod decls `thenTc` \ (env,bs) ->
- zonkCoreBinds bs `thenNF_Tc` \ bs' ->
- returnTc (env, bs'))
+ tcCoreDecls this_mod decls
-- ; printIfaceDump dflags maybe_tc_stuff
-- (in the event that it needs to be, I'm returning the PCS passed in.)
; case maybe_tc_stuff of
Nothing -> return Nothing
- Just (e,bs) -> return (Just (pcs, e, bs)) }
+ Just result -> return (Just (pcs, result)) }
where
this_mod = mi_module mod_iface
core_decls = [d | (TyClD d) <- decls, isCoreDecl d]
+
tcCoreDecls :: Module
-> [RenamedHsDecl] -- All interface-file decls
- -> TcM (TypeEnv, [TypecheckedCoreBind])
+ -> TcM (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])
tcCoreDecls this_mod decls
-- The decls are all TyClD declarations coming from External Core input.
= let
tycl_decls = [d | TyClD d <- decls]
+ rule_decls = [d | RuleD d <- decls]
core_decls = filter isCoreDecl tycl_decls
in
fixTc (\ ~(unf_env, _) ->
-- This fixTc follows the same general plan as tcImports,
-- which is better commented.
-- [ Q: do we need to tie a knot for External Core? ]
- tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ tycl_things ->
+ tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
tcExtendGlobalEnv tycl_things $
- tcCoreBinds tycl_decls `thenTc` \ core_binds ->
- tcGetEnv `thenTc` \ env ->
- returnTc (env, core_binds)
- ) `thenTc` \ ~(final_env,bs) ->
- let
- src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
- in
- returnTc (mkTypeEnv src_things, bs)
+ tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids $
+
+ tcCoreBinds core_decls `thenTc` \ core_prs ->
+ let
+ local_ids = map fst core_prs
+ in
+ tcExtendGlobalValEnv local_ids $
+
+ tcIfaceRules rule_decls `thenTc` \ rules ->
+
+ let
+ src_things = filter (isLocalThing this_mod) tycl_things
+ ++ map AnId local_ids
+ in
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnTc (env, (mkTypeEnv src_things, core_prs, rules))
+ ) `thenTc` \ (_, result) ->
+ returnTc result
\end{code}
import TcMonad
import Inst ( InstOrigin(..),
emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE,
- newMethod, newOverloadedLit, newDicts, tcInstDataCon
+ newMethod, newMethodFromName, newOverloadedLit, newDicts, tcInstDataCon
)
import Id ( mkLocalId, mkSysLocal )
import Name ( Name )
returnTc (LitPat simple_lit pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
tcPat tc_bndr pat@(NPatIn over_lit) pat_ty
- = newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
- tcLookupGlobalId eqName `thenNF_Tc` \ eq_sel_id ->
- newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ eq ->
+ = newOverloadedLit origin over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
+ newMethodFromName origin pat_ty eqName `thenNF_Tc` \ eq ->
returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr),
lie1 `plusLIE` unitLIE eq,
\begin{code}
tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
= tc_bndr name pat_ty `thenTc` \ (co_fn, lie1, bndr_id) ->
+ newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie2) ->
+ newMethodFromName origin pat_ty geName `thenNF_Tc` \ ge ->
+
-- The '-' part is re-mappable syntax
tcLookupId minus_name `thenNF_Tc` \ minus_sel_id ->
- tcLookupGlobalId geName `thenNF_Tc` \ ge_sel_id ->
- newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie2) ->
- newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ ge ->
newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ minus ->
returnTc (NPlusKPat bndr_id i pat_ty
import HsSyn ( TyClDecl(..),
ConDecl(..), Sig(..), HsPred(..),
tyClDeclName, hsTyVarNames, tyClDeclTyVars,
- isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
+ isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig
)
import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
import BasicTypes ( RecFlag(..), NewOrData(..) )
import Module ( Module )
import TcMonad
-import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
+import TcEnv ( TcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
tcExtendKindEnv, tcLookup, tcExtendGlobalEnv,
isLocalThing )
import TcTyDecls ( tcTyDecl, kcConDetails )
The main function
~~~~~~~~~~~~~~~~~
\begin{code}
-tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff
- -> Module -- Current module
+tcTyAndClassDecls :: Module -- Current module
-> [RenamedTyClDecl]
-> TcM [TyThing] -- Returns newly defined things:
-- types, classes and implicit Ids
-tcTyAndClassDecls unf_env this_mod decls
+tcTyAndClassDecls this_mod decls
= sortByDependency decls `thenTc` \ groups ->
- tcGroups unf_env this_mod groups
+ tcGroups this_mod groups
-tcGroups unf_env this_mod []
- = tcGetEnv `thenNF_Tc` \ env ->
- returnTc []
+tcGroups this_mod []
+ = returnTc []
-tcGroups unf_env this_mod (group:groups)
- = tcGroup unf_env this_mod group `thenTc` \ (env, new_things1) ->
- tcSetEnv env $
- tcGroups unf_env this_mod groups `thenTc` \ new_things2 ->
+tcGroups this_mod (group:groups)
+ = tcGroup this_mod group `thenTc` \ (env, new_things1) ->
+ tcSetEnv env $
+ tcGroups this_mod groups `thenTc` \ new_things2 ->
returnTc (new_things1 ++ new_things2)
\end{code}
@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
\begin{code}
-tcGroup :: RecTcEnv -> Module -> SCC RenamedTyClDecl
+tcGroup :: Module -> SCC RenamedTyClDecl
-> TcM (TcEnv, -- Input env extended by types and classes only
[TyThing]) -- Things defined by this group
-tcGroup unf_env this_mod scc
+tcGroup this_mod scc
= getDOptsTc `thenNF_Tc` \ dflags ->
-- Step 1
mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
-- Step 5
-- Extend the environment with the final
-- TyCons/Classes and check the decls
- tcExtendGlobalEnv all_tyclss $
- mapTc (tcTyClDecl1 unf_env) decls `thenTc` \ tycls_details ->
+ tcExtendGlobalEnv all_tyclss $
+ mapTc tcTyClDecl1 decls `thenTc` \ tycls_details ->
-- Return results
- tcGetEnv `thenNF_Tc` \ env ->
+ tcGetEnv `thenNF_Tc` \ env ->
returnTc (tycls_details, env, all_tyclss)
) `thenTc` \ (_, env, all_tyclss) ->
AcyclicSCC decl -> [decl]
CyclicSCC decls -> decls
-tcTyClDecl1 unf_env decl
+tcTyClDecl1 decl
| isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
- | otherwise = tcAddDeclCtxt decl (tcTyDecl unf_env decl)
+ | otherwise = tcAddDeclCtxt decl (tcTyDecl decl)
-- We do the validity check over declarations, rather than TyThings
-- only so that we can add a nice context with tcAddDeclCtxt
in
returnTc decl_sccs
where
- tycl_decls = filter (not . isIfaceSigDecl) decls
+ tycl_decls = filter isTypeOrClassDecl decls
edges = map mkEdges tycl_decls
is_syn_decl (d, _, _) = isSynDecl d
%************************************************************************
\begin{code}
-tcTyDecl :: RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
-tcTyDecl unf_env (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs})
+tcTyDecl :: RenamedTyClDecl -> TcM (Name, TyThingDetails)
+tcTyDecl (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs})
= tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
tcExtendTyVarEnv (tyConTyVars tycon) $
tcHsType rhs `thenTc` \ rhs_ty ->
returnTc (tycon_name, SynTyDetails rhs_ty)
-tcTyDecl unf_env (TyData {tcdND = new_or_data, tcdCtxt = context,
+tcTyDecl (TyData {tcdND = new_or_data, tcdCtxt = context,
tcdName = tycon_name, tcdCons = con_decls})
= tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
let
tcHsTheta context `thenTc` \ ctxt ->
tcConDecls new_or_data tycon tyvars ctxt con_decls `thenTc` \ data_cons ->
let
- sel_ids = mkRecordSelectors unf_env tycon data_cons
+ sel_ids = mkRecordSelectors tycon data_cons
in
returnTc (tycon_name, DataTyDetails ctxt data_cons sel_ids)
-tcTyDecl unf_env (ForeignType {tcdName = tycon_name})
+tcTyDecl (ForeignType {tcdName = tycon_name})
= returnTc (tycon_name, ForeignTyDetails)
-mkRecordSelectors unf_env tycon data_cons
+mkRecordSelectors tycon data_cons
= -- We'll check later that fields with the same name
-- from different constructors have the same type.
- [ mkRecordSelId tycon field unpack_id unpackUtf8_id
+ [ mkRecordSelId tycon field
| field <- nubBy eq_name fields ]
where
fields = [ field | con <- visibleDataCons data_cons,
field <- dataConFieldLabels con ]
eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2
-
- unpack_id = tcLookupRecId unf_env unpackCStringName
- unpackUtf8_id = tcLookupRecId unf_env unpackCStringUtf8Name
\end{code}
\begin{code}
module UnicodeUtil(
- stringToUtf8
+ stringToUtf8, intsToUtf8
) where
#include "HsVersions.h"
import Panic ( panic )
-import Char ( chr )
+import Char ( chr, ord )
\end{code}
\begin{code}
-stringToUtf8 :: [Int] -> String
-stringToUtf8 [] = ""
-stringToUtf8 (c:s)
- | c >= 1 && c <= 0x7F = chr c : stringToUtf8 s
+stringToUtf8 :: String -> String
+stringToUtf8 s = intsToUtf8 (map ord s)
+
+intsToUtf8 :: [Int] -> String
+intsToUtf8 [] = ""
+intsToUtf8 (c:s)
+ | c >= 1 && c <= 0x7F = chr c : intsToUtf8 s
| c < 0 = panic ("charToUtf8 ("++show c++")")
| c <= 0x7FF = chr (0xC0 + c `div` 0x40 ) :
chr (0x80 + c `mod` 0x40) :
- stringToUtf8 s
+ intsToUtf8 s
| c <= 0xFFFF = chr (0xE0 + c `div` 0x1000 ) :
chr (0x80 + c `div` 0x40 `mod` 0x40) :
chr (0x80 + c `mod` 0x40) :
- stringToUtf8 s
+ intsToUtf8 s
| c <= 0x10FFFF = chr (0xF0 + c `div` 0x40000 ) :
chr (0x80 + c `div` 0x1000 `mod` 0x40) :
chr (0x80 + c `div` 0x40 `mod` 0x40) :
chr (0x80 + c `mod` 0x40) :
- stringToUtf8 s
+ intsToUtf8 s
| otherwise = panic ("charToUtf8 "++show c)
\end{code}
projects / ghc-hetmet.git / commitdiff