import HsSyn
-import TcHsSyn ( TypecheckedPat )
+import TcHsSyn ( TypecheckedPat, outPatType )
import TcType ( tcTyConAppTyCon, tcTyConAppArgs )
-import DsHsSyn ( outPatType )
import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet,
CanItFail(..), tidyLitPat, tidyNPat,
)
import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) )
import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
import ForeignCall ( ForeignCall, CCallTarget(..) )
-import TcType ( isUnLiftedType, mkFunTys,
- tcSplitTyConApp_maybe, tyVarsOfType, mkForAllTys, isPrimitiveType,
- isUnLiftedType, mkFunTy, mkTyConApp,
- tcEqType, isBoolTy, isUnitTy,
- Type
+
+import TcType ( Type, isUnLiftedType, mkFunTys, mkFunTy,
+ tyVarsOfType, mkForAllTys, mkTyConApp,
+ isBoolTy, isUnitTy, isPrimitiveType
)
+import Type ( splitTyConApp_maybe, repType, eqType ) -- Sees the representation type
import PrimOp ( PrimOp(TouchOp) )
import TysPrim ( realWorldStatePrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
prim_arg
[(DEFAULT,[],body)])
+ -- Newtypes
-- Data types with a single constructor, which has a single, primitive-typed arg
-- This deals with Int, Float etc
| is_product_type && data_con_arity == 1
= getSrcLocDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
- arg_ty = exprType arg
+ arg_ty = repType (exprType arg)
+ -- The repType looks through any newtype or
+ -- implicit-parameter wrappings on the argument.
maybe_product_type = splitProductType_maybe arg_ty
is_product_type = maybeToBool maybe_product_type
Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
(data_con_arg_ty1 : _) = data_con_arg_tys
(_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
- maybe_arg3_tycon = tcSplitTyConApp_maybe data_con_arg_ty3
+ maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
Just (arg3_tycon,_) = maybe_arg3_tycon
\end{code}
-- the call. The arg_ids passed in are the Ids passed to the actual ccall.
boxResult arg_ids result_ty
- = case tcSplitTyConApp_maybe result_ty of
+ = case splitTyConApp_maybe result_ty of
-- The result is IO t, so wrap the result in an IO constructor
Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
mkTouches [] s cont = returnDs (cont s)
mkTouches (v:vs) s cont
- | not (idType v `tcEqType` foreignObjPrimTy) = mkTouches vs s cont
+ | not (idType v `eqType` foreignObjPrimTy) = mkTouches vs s cont
| otherwise = newSysLocalDs realWorldStatePrimTy `thenDs` \s' ->
mkTouches vs s' cont `thenDs` \ rest ->
returnDs (Case (mkApps (Var touchzh) [Type foreignObjPrimTy,
CoreExpr -> CoreExpr) -- Wrapper for the result
resultWrapper result_ty
-- Base case 1: primitive types
- | isPrimitiveType result_ty
+ | isPrimitiveType result_ty_rep
= (Just result_ty, \e -> e)
- -- Base case 1: the unit type ()
- | isUnitTy result_ty
+ -- Base case 2: the unit type ()
+ | isUnitTy result_ty_rep
= (Nothing, \e -> Var unitDataConId)
- | isBoolTy result_ty
+ -- Base case 3: the boolean type ()
+ | isBoolTy result_ty_rep
= (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
-- Data types with a single constructor, which has a single arg
- | is_product_type && data_con_arity == 1
+ | Just (_, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty_rep,
+ dataConSourceArity data_con == 1
= let
(maybe_ty, wrapper) = resultWrapper unwrapped_res_ty
(unwrapped_res_ty : _) = data_con_arg_tys
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
where
- maybe_product_type = splitProductType_maybe result_ty
- is_product_type = maybeToBool maybe_product_type
- Just (_, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
- data_con_arity = dataConSourceArity data_con
+ result_ty_rep = repType result_ty
\end{code}
Match(..), HsBinds(..), MonoBinds(..),
mkSimpleMatch
)
-import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt )
+import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, outPatType )
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+-- needs to see source types (newtypes etc), and sometimes not
+-- So WATCH OUT; check each use of split*Ty functions.
+-- Sigh. This is a pain.
+
import TcType ( tcSplitAppTy, tcSplitFunTys, tcSplitTyConApp_maybe, tcTyConAppArgs,
isIntegerTy, tcSplitTyConApp, isUnLiftedType, Type )
+import Type ( splitFunTys )
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
= dsExpr op `thenDs` \ core_op ->
-- for the type of y, we need the type of op's 2nd argument
let
- (x_ty:y_ty:_, _) = tcSplitFunTys (exprType core_op)
+ (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
+ -- Must look through an implicit-parameter type;
+ -- newtype impossible; hence Type.splitFunTys
in
dsExpr expr `thenDs` \ x_core ->
newSysLocalDs x_ty `thenDs` \ x_id ->
= dsExpr op `thenDs` \ core_op ->
-- for the type of x, we need the type of op's 2nd argument
let
- (x_ty:y_ty:_, _) = tcSplitFunTys (exprType core_op)
+ (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
+ -- See comment with SectionL
in
dsExpr expr `thenDs` \ y_core ->
newSysLocalDs x_ty `thenDs` \ x_id ->
\underline{\bf Various data construction things}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-dsExpr (ExplicitListOut ty xs)
+dsExpr (ExplicitList ty xs)
= go xs
where
go [] = returnDs (mkNilExpr ty)
= dsExpr con_expr `thenDs` \ con_expr' ->
let
(arg_tys, _) = tcSplitFunTys (exprType con_expr')
+ -- A newtype in the corner should be opaque;
+ -- hence TcType.tcSplitFunTys
mk_arg (arg_ty, lbl)
= case [rhs | (sel_id,rhs,_) <- rbinds,
dictionaries.
\begin{code}
-dsExpr (RecordUpdOut record_expr record_out_ty dicts [])
+dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty dicts [])
= dsExpr record_expr
-dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
+dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty dicts rbinds)
= getSrcLocDs `thenDs` \ src_loc ->
dsExpr record_expr `thenDs` \ record_expr' ->
-- necessary so that we don't lose sharing
let
- record_in_ty = exprType record_expr'
- in_inst_tys = tcTyConAppArgs record_in_ty
- out_inst_tys = tcTyConAppArgs record_out_ty
+ in_inst_tys = tcTyConAppArgs record_in_ty -- Newtype opaque
+ out_inst_tys = tcTyConAppArgs record_out_ty -- Newtype opaque
mk_val_arg field old_arg_id
= case [rhs | (sel_id, rhs, _) <- rbinds,
in
returnDs (mkSimpleMatch [ConPat con record_in_ty [] [] (map VarPat arg_ids)]
rhs
- (Just record_out_ty)
+ record_out_ty
src_loc)
in
-- Record stuff doesn't work for existentials
#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
dsExpr (HsDo _ _ _) = panic "dsExpr:HsDo"
-dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList"
dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
#endif
| otherwise = do_expr expr locn `thenDs` \ expr2 ->
returnDs (mkApps (Var return_id) [Type b_ty, expr2])
- go (ExprStmt expr locn : stmts)
+ go (ExprStmt expr a_ty locn : stmts)
| is_do -- Do expression
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
- let
- (_, a_ty) = tcSplitAppTy (exprType expr2) -- Must be of form (m a)
- in
newSysLocalDs a_ty `thenDs` \ ignored_result_id ->
returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
Lam ignored_result_id rest])
= putSrcLocDs locn $
dsExpr expr `thenDs` \ expr2 ->
let
- (_, a_ty) = tcSplitAppTy (exprType expr2) -- Must be of form (m a)
+ a_ty = outPatType pat
fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty])
(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)
- (Just result_ty) locn
+ result_ty locn
the_matches
| failureFreePat pat = [main_match]
| otherwise =
[ main_match
- , mkSimpleMatch [WildPat a_ty] fail_expr (Just result_ty) locn
+ , mkSimpleMatch [WildPat a_ty] fail_expr result_ty locn
]
in
matchWrapper (DoCtxt do_or_lc) the_matches `thenDs` \ (binders, matching_code) ->
mkForeignExportOcc, isLocalName,
NamedThing(..),
)
-import TcType ( tcSplitTyConApp_maybe, tcFunResultTy,
- tcSplitFunTys, tcSplitForAllTys,
+
+ -- Import Type not TcType; in this module we are generating code
+ -- to marshal representation types across to C
+import Type ( splitTyConApp_maybe, funResultTy,
+ splitFunTys, splitForAllTys, splitAppTy,
Type, mkFunTys, mkForAllTys, mkTyConApp,
- mkFunTy, tcSplitAppTy, applyTy, tcEqType, isUnitTy
+ mkFunTy, applyTy, eqType, repType
)
-import Type ( repType )
+
import ForeignCall ( ForeignCall(..), CCallSpec(..),
Safety(..), playSafe,
CExportSpec(..),
CCallConv(..), ccallConvToInt
)
import CStrings ( CLabelString )
-import TysWiredIn ( addrTy, stablePtrTyCon )
+import TysWiredIn ( addrTy, unitTy, stablePtrTyCon )
import TysPrim ( addrPrimTy )
import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
bindIOName, returnIOName
-> FoImport
-> DsM ([Binding], SDoc, SDoc)
dsFImport mod_name lbl_id (LblImport ext_nm)
- = ASSERT(fromJust res_ty `tcEqType` addrPrimTy) -- typechecker ensures this
+ = ASSERT(fromJust res_ty `eqType` addrPrimTy) -- typechecker ensures this
returnDs ([(lbl_id, rhs)], empty, empty)
where
(res_ty, fo_rhs) = resultWrapper (idType lbl_id)
dsFCall mod_Name fn_id fcall
= let
ty = idType fn_id
- (tvs, fun_ty) = tcSplitForAllTys ty
- (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
+ (tvs, fun_ty) = splitForAllTys ty
+ (arg_tys, io_res_ty) = splitFunTys fun_ty
in
newSysLocalsDs arg_tys `thenDs` \ args ->
mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) ->
-- Look at the result type of the exported function, orig_res_ty
-- If it's IO t, return (\x.x, IO t, t)
-- If it's plain t, return (\x.returnIO x, IO t, t)
- (case tcSplitTyConApp_maybe orig_res_ty of
+ (case splitTyConApp_maybe orig_res_ty of
Just (ioTyCon, [res_ty])
-> ASSERT( ioTyCon `hasKey` ioTyConKey )
-- The function already returns IO t
other -> -- The function returns t, so wrap the call in returnIO
dsLookupGlobalValue returnIOName `thenDs` \ retIOId ->
returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body],
- tcFunResultTy (applyTy (idType retIOId) orig_res_ty),
+ funResultTy (applyTy (idType retIOId) orig_res_ty),
-- We don't have ioTyCon conveniently to hand
orig_res_ty)
returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
where
- (tvs,sans_foralls) = tcSplitForAllTys ty
- (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls
+ (tvs,sans_foralls) = splitForAllTys ty
+ (fe_arg_tys', orig_res_ty) = splitFunTys sans_foralls
- (_, stbl_ptr_ty') = tcSplitForAllTys stbl_ptr_ty
- (_, stbl_ptr_to_ty) = tcSplitAppTy stbl_ptr_ty'
+ (_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty
+ (_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty'
fe_arg_tys | isDyn = tail fe_arg_tys'
| otherwise = fe_arg_tys'
where
ty = idType id
- (tvs,sans_foralls) = tcSplitForAllTys ty
- ([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls
- Just (ioTyCon, [res_ty]) = tcSplitTyConApp_maybe io_res_ty
+ (tvs,sans_foralls) = splitForAllTys ty
+ ([arg_ty], io_res_ty) = splitFunTys sans_foralls
+ Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res_ty
export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
toCName :: Id -> String
cParamTypes = map showStgType real_args
- res_ty_is_unit = isUnitTy res_ty
+ res_ty_is_unit = res_ty `eqType` unitTy
cResType | res_ty_is_unit = text "void"
| otherwise = showStgType res_ty
showFFIType :: Type -> String
showFFIType t = getOccString (getName tc)
where
- tc = case tcSplitTyConApp_maybe (repType t) of
+ tc = case splitTyConApp_maybe (repType t) of
Just (tc,_) -> tc
Nothing -> pprPanic "showFFIType" (ppr t)
\end{code}
import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..) )
import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt, TypecheckedMatchContext )
import CoreSyn ( CoreExpr )
-import TcType ( Type )
+import Type ( Type )
import DsMonad
import DsUtils
-> TypecheckedGRHSs -- Guarded RHSs
-> DsM (Type, MatchResult)
-dsGRHSs kind pats (GRHSs grhss binds (Just ty))
+dsGRHSs kind pats (GRHSs grhss binds ty)
= mapDs (dsGRHS kind pats) grhss `thenDs` \ match_results ->
let
match_result1 = foldr1 combineMatchResults match_results
-- ExprStmts must be guards
-- Turn an "otherwise" guard is a no-op
-matchGuard (ExprStmt (HsVar v) _ : stmts) ctx
+matchGuard (ExprStmt (HsVar v) _ _ : stmts) ctx
| v `hasKey` otherwiseIdKey
|| v `hasKey` trueDataConKey
= matchGuard stmts ctx
-matchGuard (ExprStmt expr locn : stmts) ctx
+matchGuard (ExprStmt expr _ locn : stmts) ctx
= matchGuard stmts ctx `thenDs` \ match_result ->
putSrcLocDs locn (dsExpr expr) `thenDs` \ pred_expr ->
returnDs (mkGuardedMatchResult pred_expr match_result)
TypecheckedMonoBinds )
import Id ( idType, Id )
-import TcType ( Type )
-import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
-import BasicTypes ( Boxity(..) )
+import Type ( Type )
\end{code}
-Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
-then something is wrong.
-\begin{code}
-outPatType :: TypecheckedPat -> Type
-
-outPatType (WildPat ty) = ty
-outPatType (VarPat var) = idType var
-outPatType (LazyPat pat) = outPatType pat
-outPatType (AsPat var pat) = idType var
-outPatType (ConPat _ ty _ _ _) = ty
-outPatType (ListPat ty _) = mkListTy ty
-outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
-outPatType (RecPat _ ty _ _ _) = ty
-outPatType (LitPat lit ty) = ty
-outPatType (NPat lit ty _) = ty
-outPatType (NPlusKPat _ _ ty _ _) = ty
-outPatType (DictPat ds ms) = case (length ds_ms) of
- 0 -> unitTy
- 1 -> idType (head ds_ms)
- n -> mkTupleTy Boxed n (map idType ds_ms)
- where
- ds_ms = ds ++ ms
-\end{code}
-
-
-Nota bene: @DsBinds@ relies on the fact that at least for simple
-tuple patterns @collectTypedPatBinders@ returns the binders in
-the same order as they appear in the tuple.
-
-@collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.
-
-\begin{code}
-collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id]
-collectTypedMonoBinders EmptyMonoBinds = []
-collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
-collectTypedMonoBinders (FunMonoBind f _ _ _) = [f]
-collectTypedMonoBinders (VarMonoBind v _) = [v]
-collectTypedMonoBinders (CoreMonoBind v _) = [v]
-collectTypedMonoBinders (AndMonoBinds bs1 bs2)
- = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
-collectTypedMonoBinders (AbsBinds _ _ exports _ _)
- = [global | (_, global, local) <- exports]
-
-collectTypedPatBinders :: TypecheckedPat -> [Id]
-collectTypedPatBinders (VarPat var) = [var]
-collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
-collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
-collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
- fields)
-collectTypedPatBinders (DictPat ds ms) = ds ++ ms
-collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
-collectTypedPatBinders any_other_pat = [ {-no binders-} ]
-\end{code}
import BasicTypes ( Boxity(..) )
import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..), HsDoContext(..) )
-import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr )
-import DsHsSyn ( outPatType )
+import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr, outPatType )
import CoreSyn
import DsMonad -- the monadery used in the desugarer
import CoreUtils ( exprType, mkIfThenElse )
import Id ( idType )
import Var ( Id )
-import TcType ( mkTyVarTy, mkFunTys, mkFunTy, Type )
+import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type )
import TysPrim ( alphaTyVar )
import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, mkListTy, mkTupleTy )
import Match ( matchSimply )
returnDs (mkConsExpr (exprType core_expr) core_expr list)
-- Non-last: must be a guard
-deListComp (ExprStmt guard locn : quals) list -- rule B above
+deListComp (ExprStmt guard ty locn : quals) list -- rule B above
= dsExpr guard `thenDs` \ core_guard ->
deListComp quals list `thenDs` \ core_rest ->
returnDs (mkIfThenElse core_guard core_rest list)
returnDs (mkApps (Var c_id) [core_expr, Var n_id])
-- Non-last: must be a guard
-dfListComp c_id n_id (ExprStmt guard locn : quals)
+dfListComp c_id n_id (ExprStmt guard ty locn : quals)
= dsExpr guard `thenDs` \ core_guard ->
dfListComp c_id n_id quals `thenDs` \ core_rest ->
returnDs (mkIfThenElse core_guard core_rest (Var n_id))
import Var ( TyVar, setTyVarUnique )
import Outputable
import SrcLoc ( noSrcLoc, SrcLoc )
-import TcType ( Type )
+import Type ( Type )
import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
import Unique ( Unique )
import {-# SOURCE #-} Match ( matchSimply )
import HsSyn
-import TcHsSyn ( TypecheckedPat )
-import DsHsSyn ( outPatType, collectTypedPatBinders )
+import TcHsSyn ( TypecheckedPat, outPatType, collectTypedPatBinders )
import CoreSyn
import DsMonad
import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
import TyCon ( isNewTyCon, tyConDataCons, isRecursiveTyCon )
import DataCon ( DataCon, dataConStrictMarks, dataConId )
-import TcType ( mkFunTy, isUnLiftedType, Type )
-import TcType ( tcSplitTyConApp, isIntTy, isFloatTy, isDoubleTy )
+import Type ( mkFunTy, isUnLiftedType, Type )
+import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy )
import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy )
import TysWiredIn ( nilDataCon, consDataCon,
tupleCon,
= MatchResult fail_flag mk_case
where
-- Common stuff
- scrut_ty = idType var
- (tycon, _) = tcSplitTyConApp scrut_ty -- Newtypes must be opaque here
+ scrut_ty = idType var
+ tycon = tcTyConAppTyCon scrut_ty -- Newtypes must be opaque here
-- Stuff for newtype
(_, arg_ids, match_result) = head match_alts
\end{code}
-
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
-import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext )
-import DsHsSyn ( outPatType )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
import CoreUtils ( bindNonRec )
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
import PrelInfo ( pAT_ERROR_ID )
-import TcType ( mkTyVarTys, Type, tcSplitTyConApp, tcEqType )
+import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
import BasicTypes ( Boxity(..) )
import UniqSet
pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
- (_, inst_tys) = tcSplitTyConApp pat_ty
+ inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque
con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con)
import Id ( Id )
import CoreSyn
-import TcType ( mkTyVarTys )
+import Type ( mkTyVarTys )
import ListSetOps ( equivClassesByUniq )
import Unique ( Uniquable(..) )
\end{code}
import Literal ( mkMachInt, Literal(..) )
import Maybes ( catMaybes )
-import TcType ( isUnLiftedType )
+import Type ( isUnLiftedType )
import Panic ( panic, assertPanic )
\end{code}
-- friends:
import HsBinds ( HsBinds(..), nullBinds )
+import HsTypes ( PostTcType )
import HsLit ( HsLit, HsOverLit )
import BasicTypes ( Fixity(..) )
import HsTypes ( HsType )
SrcLoc
| ExplicitList -- syntactic list
- [HsExpr id pat]
- | ExplicitListOut -- TRANSLATION
- Type -- Gives type of components of list
+ PostTcType -- Gives type of components of list
[HsExpr id pat]
| ExplicitTuple -- tuple
(HsRecordBinds id pat)
| RecordUpdOut (HsExpr id pat) -- TRANSLATION
+ Type -- Type of *input* record
Type -- Type of *result* record (may differ from
- -- type of input record)
+ -- type of input record)
[id] -- Dicts needed for construction
(HsRecordBinds id pat)
-- NOTE: this CCall is the *boxed*
-- version; the desugarer will convert
-- it into the unboxed "ccall#".
- Type -- The result type; will be *bottom*
+ PostTcType -- The result type; will be *bottom*
-- until the typechecker gets ahold of it
| HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation
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)))
-ppr_expr (ExplicitListOut ty exprs)
+ppr_expr (ExplicitList _ exprs)
= brackets (fsep (punctuate comma (map ppr_expr exprs)))
ppr_expr (ExplicitTuple exprs boxity)
ppr_expr (RecordUpd aexp rbinds)
= pp_rbinds (pprParendExpr aexp) rbinds
-ppr_expr (RecordUpdOut aexp _ _ rbinds)
+ppr_expr (RecordUpdOut aexp _ _ _ rbinds)
= pp_rbinds (pprParendExpr aexp) rbinds
ppr_expr (ExprWithTySig expr sig)
HsVar _ -> pp_as_was
HsIPVar _ -> pp_as_was
- ExplicitList _ -> pp_as_was
- ExplicitListOut _ _ -> pp_as_was
+ ExplicitList _ _ -> pp_as_was
ExplicitTuple _ _ -> pp_as_was
HsPar _ -> pp_as_was
data GRHSs id pat
= GRHSs [GRHS id pat] -- Guarded RHSs
(HsBinds id pat) -- The where clause
- (Maybe Type) -- Just rhs_ty after type checking
+ PostTcType -- Type of RHS (after type checking)
data GRHS id pat
= GRHS [Stmt id pat] -- The RHS is the final ResultStmt
-- it printed 'wrong' in error messages
SrcLoc
-mkSimpleMatch :: [pat] -> HsExpr id pat -> Maybe Type -> SrcLoc -> Match id pat
-mkSimpleMatch pats rhs maybe_rhs_ty locn
- = Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds maybe_rhs_ty)
+mkSimpleMatch :: [pat] -> HsExpr id pat -> Type -> SrcLoc -> Match id pat
+mkSimpleMatch pats rhs rhs_ty locn
+ = Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty)
unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat]
unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc]
pprGRHSs :: (Outputable id, Outputable pat)
=> HsMatchContext id -> GRHSs id pat -> SDoc
-pprGRHSs ctxt (GRHSs grhss binds maybe_ty)
+pprGRHSs ctxt (GRHSs grhss binds ty)
= vcat (map (pprGRHS ctxt) grhss)
$$
(if nullBinds binds then empty
data Stmt id pat
= BindStmt pat (HsExpr id pat) SrcLoc
| LetStmt (HsBinds id pat)
- | ResultStmt (HsExpr id pat) SrcLoc -- See notes that follow
- | ExprStmt (HsExpr id pat) SrcLoc -- See notes that follow
- | ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals
- | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming; the ids are the binders
- -- bound by the stmts
+ | ResultStmt (HsExpr id pat) SrcLoc -- See notes that follow
+ | ExprStmt (HsExpr id pat) PostTcType SrcLoc -- See notes that follow
+ -- The type is the *element type* of the expression
+ | ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals
+ | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming; the ids are the binders
+ -- bound by the stmts
\end{code}
ExprStmts and ResultStmts are a bit tricky, because what they mean
A do expression of type (m res_ty)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- * ExprStmt E: do { ....; E; ... }
+ * ExprStmt E any_ty: do { ....; E; ... }
E :: m any_ty
Translation: E >> ...
A list comprehensions of type [elt_ty]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- * ExprStmt E: [ .. | .... E ]
+ * ExprStmt E Bool: [ .. | .... E ]
[ .. | ..., E, ... ]
[ .. | .... | ..., E | ... ]
E :: Bool
A guard list, guarding a RHS of type rhs_ty
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- * ExprStmt E: f x | ..., E, ... = ...rhs...
+ * ExprStmt E Bool: f x | ..., E, ... = ...rhs...
E :: Bool
Translation: if E then fail else ...
pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds]
-pprStmt (ExprStmt expr _) = ppr expr
+pprStmt (ExprStmt expr _ _) = ppr expr
pprStmt (ResultStmt expr _) = ppr expr
pprStmt (ParStmt stmtss)
= hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
#include "HsVersions.h"
-import Type ( Type )
+import Type ( Type )
+import HsTypes ( PostTcType )
import Outputable
import Ratio ( Rational )
\end{code}
| HsRat Rational Type -- Genuinely a rational; arises only from TRANSLATION
| HsFloatPrim Rational -- Unboxed Float
| HsDoublePrim Rational -- Unboxed Double
- | HsLitLit FAST_STRING Type -- to pass ``literal literals'' through to C
- -- also: "overloaded" type; but
- -- must resolve to boxed-primitive!
+ | HsLitLit FAST_STRING PostTcType -- to pass ``literal literals'' through to C
+ -- also: "overloaded" type; but
+ -- must resolve to boxed-primitive!
-- The Type in HsLitLit is needed when desuaring;
-- before the typechecker it's just an error value
, hsUsOnce, hsUsMany
, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
- , hsTyVarName, hsTyVarNames, replaceTyVarName
+ , hsTyVarName, hsTyVarNames, replaceTyVarName,
+
+ -- Type place holder
+ PostTcType, placeHolderType,
-- Printing
, pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
)
import FiniteMap
import Outputable
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Annotating the syntax}
+%* *
+%************************************************************************
+\begin{code}
+type PostTcType = Type -- Used for slots in the abstract syntax
+ -- where we want to keep slot for a type
+ -- to be added by the type checker...but
+ -- before typechecking it's just bogus
+
+placeHolderType :: PostTcType -- Used before typechecking
+placeHolderType = panic "Evaluated the place holder for a PostTcType"
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Data types}
+%* *
+%************************************************************************
+
This is the syntax for types as seen in type signatures.
\begin{code}
Nothing -> return (pcs0, Nothing)
Just parsed_stmt -> do {
- let { notExprStmt (ExprStmt _ _) = False;
- notExprStmt _ = True
+ let { notExprStmt (ExprStmt _ _ _) = False;
+ notExprStmt _ = True
};
if (just_expr && notExprStmt parsed_stmt)
-- Typecheck it
maybe_tc_return <-
if just_expr
- then case rn_stmt of { (syn, ExprStmt e _, decls) ->
+ then case rn_stmt of { (syn, ExprStmt e _ _, decls) ->
typecheckExpr dflags pcs1 hst type_env
print_unqual iNTERACTIVE (syn,e,decls) }
else typecheckStmt dflags pcs1 hst type_env
\begin{code}
module ParseUtil (
parseError -- String -> Pa
- , cbot -- a
, mkVanillaCon, mkRecCon,
, mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
getSrcLocP `thenP` \ loc ->
failMsgP (hcat [ppr loc, text ": ", text s])
-cbot = panic "CCall:result_ty"
-----------------------------------------------------------------------------
-- mkVanillaCon
-- checkDo (a) checks that the last thing is an ExprStmt
-- (b) transforms it to a ResultStmt
-checkDo [] = parseError "Empty 'do' construct"
-checkDo [ExprStmt e l] = returnP [ResultStmt e l]
-checkDo [s] = parseError "The last statement in a 'do' construct must be an expression"
-checkDo (s:ss) = checkDo ss `thenP` \ ss' ->
- returnP (s:ss')
+checkDo [] = parseError "Empty 'do' construct"
+checkDo [ExprStmt e _ l] = returnP [ResultStmt e l]
+checkDo [s] = parseError "The last statement in a 'do' construct must be an expression"
+checkDo (s:ss) = checkDo ss `thenP` \ ss' ->
+ returnP (s:ss')
---------------------------------------------------------------------------
-- Checking Patterns.
_ -> patFail
HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
- ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+ ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
returnP (ListPatIn ps)
ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.69 2001/06/27 11:15:34 simonmar Exp $
+$Id: Parser.y,v 1.70 2001/07/12 16:21:23 simonpj Exp $
Haskell grammar.
rhs :: { RdrNameGRHSs }
- : '=' srcloc exp wherebinds { (GRHSs (unguardedRHS $3 $2)
- $4 Nothing)}
- | gdrhs wherebinds { GRHSs (reverse $1) $2 Nothing }
+ : '=' srcloc exp wherebinds { (GRHSs (unguardedRHS $3 $2) $4 placeHolderType)}
+ | gdrhs wherebinds { GRHSs (reverse $1) $2 placeHolderType }
gdrhs :: { [RdrNameGRHS] }
: gdrhs gdrh { $2 : $1 }
{% checkPatterns $2 ($3 : reverse $4) `thenP` \ ps ->
returnP (HsLam (Match [] ps $5
(GRHSs (unguardedRHS $8 $7)
- EmptyBinds Nothing))) }
+ EmptyBinds placeHolderType))) }
| 'let' declbinds 'in' exp { HsLet $2 $4 }
| 'if' srcloc exp 'then' exp 'else' exp { HsIf $3 $5 $7 $2 }
| 'case' srcloc exp 'of' altslist { HsCase $3 $5 $2 }
| srcloc 'do' stmtlist {% checkDo $3 `thenP` \ stmts ->
returnP (HsDo DoExpr stmts $1) }
- | '_ccall_' ccallid aexps0 { HsCCall $2 $3 PlayRisky False cbot }
- | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 PlaySafe False cbot }
- | '_casm_' CLITLIT aexps0 { HsCCall $2 $3 PlayRisky True cbot }
- | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 PlaySafe True cbot }
+ | '_ccall_' ccallid aexps0 { HsCCall $2 $3 PlayRisky False placeHolderType }
+ | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 PlaySafe False placeHolderType }
+ | '_casm_' CLITLIT aexps0 { HsCCall $2 $3 PlayRisky True placeHolderType }
+ | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 PlaySafe True placeHolderType }
| scc_annot exp { if opt_SccProfilingOn
then HsSCC $1 $2
-- avoiding another shift/reduce-conflict.
list :: { RdrNameHsExpr }
- : exp { ExplicitList [$1] }
- | lexps { ExplicitList (reverse $1) }
+ : exp { ExplicitList placeHolderType [$1] }
+ | lexps { ExplicitList placeHolderType (reverse $1) }
| exp '..' { ArithSeqIn (From $1) }
| exp ',' exp '..' { ArithSeqIn (FromThen $1 $3) }
| exp '..' exp { ArithSeqIn (FromTo $1 $3) }
: srcloc infixexp opt_sig ralt wherebinds
{% (checkPattern $1 $2 `thenP` \p ->
returnP (Match [] [p] $3
- (GRHSs $4 $5 Nothing)) )}
+ (GRHSs $4 $5 placeHolderType)) )}
ralt :: { [RdrNameGRHS] }
: '->' srcloc exp { [GRHS [ResultStmt $3 $2] $2] }
stmt :: { RdrNameStmt }
: srcloc infixexp '<-' exp {% checkPattern $1 $2 `thenP` \p ->
returnP (BindStmt p $4 $1) }
- | srcloc exp { ExprStmt $2 $1 }
+ | srcloc exp { ExprStmt $2 placeHolderType $1 }
| srcloc 'let' declbinds { LetStmt $3 }
-----------------------------------------------------------------------------
| PRIMSTRING { HsStringPrim $1 }
| PRIMFLOAT { HsFloatPrim $1 }
| PRIMDOUBLE { HsDoublePrim $1 }
- | CLITLIT { HsLitLit $1 (error "Parser.y: CLITLIT") }
+ | CLITLIT { HsLitLit $1 placeHolderType }
srcloc :: { SrcLoc } : {% getSrcLocP }
\begin{code}
rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars)
-rnGRHSs (GRHSs grhss binds maybe_ty)
- = ASSERT( not (maybeToBool maybe_ty) )
- rnBinds binds $ \ binds' ->
+rnGRHSs (GRHSs grhss binds _)
+ = rnBinds binds $ \ binds' ->
mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
- returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
+ returnRn (GRHSs grhss' binds' placeHolderType, fvGRHSs)
rnGRHS (GRHS guarded locn)
= doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
-- Standard Haskell 1.4 guards are just a single boolean
-- expression, rather than a list of qualifiers as in the
-- Glasgow extension
- is_standard_guard [ResultStmt _ _] = True
- is_standard_guard [ExprStmt _ _, ResultStmt _ _] = True
- is_standard_guard other = False
+ is_standard_guard [ResultStmt _ _] = True
+ is_standard_guard [ExprStmt _ _ _, ResultStmt _ _] = True
+ is_standard_guard other = False
\end{code}
%************************************************************************
checkSectionPrec "right" section op' expr' `thenRn_`
returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
-rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
+rnExpr (HsCCall fun args may_gc is_casm _)
-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
= lookupOrigNames [cCallableClass_RDR,
cReturnableClass_RDR,
ioDataCon_RDR] `thenRn` \ implicit_fvs ->
rnExprs args `thenRn` \ (args', fvs_args) ->
- returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
+ returnRn (HsCCall fun args' may_gc is_casm placeHolderType,
fvs_args `plusFV` implicit_fvs)
rnExpr (HsSCC lbl expr)
-- Oh well.
-rnExpr (ExplicitList exps)
+rnExpr (ExplicitList _ exps)
= rnExprs exps `thenRn` \ (exps', fvs) ->
- returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
+ returnRn (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
rnExpr (ExplicitTuple exps boxity)
= rnExprs exps `thenRn` \ (exps', fvs) ->
where
doc = text "In a pattern in 'do' binding"
-rnStmt (ExprStmt expr src_loc) thing_inside
+rnStmt (ExprStmt expr _ src_loc) thing_inside
= pushSrcLocRn src_loc $
- rnExpr expr `thenRn` \ (expr', fv_expr) ->
- thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
+ rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ thing_inside (ExprStmt expr' placeHolderType src_loc) `thenRn` \ (result, fvs) ->
returnRn (result, fv_expr `plusFV` fvs)
rnStmt (ResultStmt expr src_loc) thing_inside
vname = mkSysLocalName uniq SLIT("v")
expr = HsLam ignorePredMatch
loc = nameSrcLoc vname
- ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) Nothing loc
+ ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) placeHolderType loc
in
returnRn (expr, unitFV name)
else
HsExpr(..), HsLit(..), HsType(..), HsPred(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
isClassOpSig, isPragSig,
- getClassDeclSysNames,
+ getClassDeclSysNames, placeHolderType
)
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import RnHsSyn ( RenamedTyClDecl,
Just user_bind -> returnTc user_bind
Nothing -> mkDefMethRhs is_inst_decl clas inst_tys sel_id loc dm_info `thenTc` \ rhs ->
returnTc (FunMonoBind meth_name False -- Not infix decl
- [mkSimpleMatch [] rhs Nothing loc] loc)
+ [mkSimpleMatch [] rhs placeHolderType loc] loc)
) `thenTc` \ meth_bind ->
-- Check the bindings; first add inst_tyvars to the envt
-- so that we don't quantify over them in nested places
\end{code}
\begin{code}
-tcMonoExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list
+tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
= unifyListTy res_ty `thenTc` \ elt_ty ->
mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
- returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
+ returnTc (ExplicitList elt_ty exprs', plusLIEs lies)
where
tc_elt elt_ty expr
= tcAddErrCtxt (listCtxt expr) $
newDicts RecordUpdOrigin theta' `thenNF_Tc` \ dicts ->
-- Phew!
- returnTc (RecordUpdOut record_expr' result_record_ty (map instToId dicts) rbinds',
+ returnTc (RecordUpdOut record_expr' record_ty result_record_ty (map instToId dicts) rbinds',
mkLIE dicts `plusLIE` record_lie `plusLIE` rbinds_lie)
tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
_ -> newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m_ty ->
newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
- unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_`
+ unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_`
returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty))
) `thenNF_Tc` \ (tc_ty, m_ty) ->
import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
Match(..), GRHSs(..), Stmt(..), HsLit(..),
HsBinds(..), HsType(..), HsDoContext(..),
- unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList
+ unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
)
import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
import RdrName ( RdrName, mkUnqual )
in
HsCase
(genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
- [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc]
+ [mkSimpleMatch [VarPatIn c_RDR] rhs placeHolderType tycon_loc]
tycon_loc
))
) {-else-} (
mk_match loc pats expr binds
= Match [] (map paren pats) Nothing
- (GRHSs (unguardedRHS expr loc) binds Nothing)
+ (GRHSs (unguardedRHS expr loc) binds placeHolderType)
where
paren p@(VarPatIn _) = p
paren other_p = ParPatIn other_p
compare_gen_Case fun lt eq gt a b
= HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
- [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing generatedSrcLoc,
- mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing generatedSrcLoc,
- mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing generatedSrcLoc]
+ [mkSimpleMatch [ConPatIn ltTag_RDR []] lt placeHolderType generatedSrcLoc,
+ mkSimpleMatch [ConPatIn eqTag_RDR []] eq placeHolderType generatedSrcLoc,
+ mkSimpleMatch [ConPatIn gtTag_RDR []] gt placeHolderType generatedSrcLoc]
generatedSrcLoc
careful_compare_Case ty lt eq gt a b
untag_Expr tycon [] expr = expr
untag_Expr tycon ((untag_this, put_tag_here) : more) expr
= HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
- [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing generatedSrcLoc]
+ [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
generatedSrcLoc
cmp_tags_Expr :: RdrName -- Comparison op
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
+ collectTypedPatBinders, outPatType,
+
-- re-exported from TcEnv
TcId,
import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
import TcMonad
-import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
-import CoreSyn ( Expr )
-import BasicTypes ( RecFlag(..) )
+import Type ( Type )
+import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
+import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
+import CoreSyn ( Expr )
+import BasicTypes ( RecFlag(..), Boxity(..) )
import Bag
import Outputable
import HscTypes ( TyThing(..) )
mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
\end{code}
+
+%************************************************************************
+%* *
+\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+%* *
+%************************************************************************
+
+Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
+then something is wrong.
+\begin{code}
+outPatType :: TypecheckedPat -> Type
+
+outPatType (WildPat ty) = ty
+outPatType (VarPat var) = idType var
+outPatType (LazyPat pat) = outPatType pat
+outPatType (AsPat var pat) = idType var
+outPatType (ConPat _ ty _ _ _) = ty
+outPatType (ListPat ty _) = mkListTy ty
+outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
+outPatType (RecPat _ ty _ _ _) = ty
+outPatType (LitPat lit ty) = ty
+outPatType (NPat lit ty _) = ty
+outPatType (NPlusKPat _ _ ty _ _) = ty
+outPatType (DictPat ds ms) = case (length ds_ms) of
+ 0 -> unitTy
+ 1 -> idType (head ds_ms)
+ n -> mkTupleTy Boxed n (map idType ds_ms)
+ where
+ ds_ms = ds ++ ms
+\end{code}
+
+
+Nota bene: @DsBinds@ relies on the fact that at least for simple
+tuple patterns @collectTypedPatBinders@ returns the binders in
+the same order as they appear in the tuple.
+
+@collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.
+
+\begin{code}
+collectTypedPatBinders :: TypecheckedPat -> [Id]
+collectTypedPatBinders (VarPat var) = [var]
+collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
+collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
+collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
+ fields)
+collectTypedPatBinders (DictPat ds ms) = ds ++ ms
+collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
+collectTypedPatBinders any_other_pat = [ {-no binders-} ]
+\end{code}
+
+
%************************************************************************
%* *
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
zonkGRHSs :: TcGRHSs
-> NF_TcM TypecheckedGRHSs
-zonkGRHSs (GRHSs grhss binds (Just ty))
+zonkGRHSs (GRHSs grhss binds ty)
= zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
tcSetEnv new_env $
let
in
mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
+ returnNF_Tc (GRHSs new_grhss new_binds new_ty)
\end{code}
%************************************************************************
returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
new_ty src_loc)
-zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
-
-zonkExpr (ExplicitListOut ty exprs)
+zonkExpr (ExplicitList ty exprs)
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (ExplicitListOut new_ty new_exprs)
+ returnNF_Tc (ExplicitList new_ty new_exprs)
zonkExpr (ExplicitTuple exprs boxed)
= mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
-zonkExpr (RecordUpdOut expr ty dicts rbinds)
+zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
- zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty ->
+ zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty ->
mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
- returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
+ returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds)
zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
zonkStmts stmts `thenNF_Tc` \ new_stmts ->
returnNF_Tc (ResultStmt new_expr locn : new_stmts)
-zonkStmts (ExprStmt expr locn : stmts)
+zonkStmts (ExprStmt expr ty locn : stmts)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
zonkStmts stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (ExprStmt new_expr locn : new_stmts)
+ returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
zonkStmts (LetStmt binds : stmts)
= zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
where
tc_grhss grhss
= mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
- returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
+ returnTc (GRHSs grhss' EmptyBinds expected_ty, plusLIEs lies)
tc_grhs (GRHS guarded locn)
= tcAddSrcLoc locn $
combine_par stmt (stmts, thing) = (stmt:stmts, thing)
-- ExprStmt
-tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp locn) thing_inside
+tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
= tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
if isDoExpr do_or_lc then
newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
- tcExpr exp (m any_ty)
+ tcExpr exp (m any_ty) `thenNF_Tc` \ (exp', lie) ->
+ returnTc (ExprStmt exp' any_ty locn, lie)
else
- tcExpr exp boolTy
- ) `thenTc` \ (exp', stmt_lie) ->
+ tcExpr exp boolTy `thenNF_Tc` \ (exp', lie) ->
+ returnTc (ExprStmt exp' boolTy locn, lie)
+ ) `thenTc` \ (stmt', stmt_lie) ->
thing_inside `thenTc` \ (thing, stmts_lie) ->
- returnTc (combine (ExprStmt exp' locn) thing,
- stmt_lie `plusLIE` stmts_lie)
+ returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie)
-- Result statements
import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
- isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch
+ isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch, placeHolderType
)
import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName,
returnIOName, bindIOName, failIOName,
\begin{code}
tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id])
-tcUserStmt names (ExprStmt expr loc)
+tcUserStmt names (ExprStmt expr _ loc)
= ASSERT( null names )
tcGetUnique `thenNF_Tc` \ uniq ->
let
fresh_it = itName uniq
the_bind = FunMonoBind fresh_it False
- [ mkSimpleMatch [] expr Nothing loc ] loc
+ [ mkSimpleMatch [] expr placeHolderType loc ] loc
in
tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_`
tc_stmts [fresh_it] [
LetStmt (MonoBind the_bind [] NonRecursive),
- ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) loc])
+ ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) placeHolderType loc])
( traceTc (text "tcs 1a") `thenNF_Tc_`
tc_stmts [fresh_it] [BindStmt (VarPatIn fresh_it) expr loc])
-- mk_return builds the expression
-- returnIO @ [()] [coerce () x, .., coerce () z]
mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
- (ExplicitListOut unitTy (map mk_item ids))
+ (ExplicitList unitTy (map mk_item ids))
mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
(HsVar id)
f x = (x::Int) + ?y
At first sight this seems reasonable, but it has the nasty property
-that adding a type signature changes the dynamic semantics.=20
+that adding a type signature changes the dynamic semantics.
Consider this:
(let f x = (x::Int) + ?y
returns (3+6, 3+5)
vs
- (let f :: Int -> Int=20
+ (let f :: Int -> Int
f x = x + ?y
in (f 3, f 3 with ?y=5)) with ?y = 6
z = (x::Int) + ?y
-The argument above suggests that we *must* generalise=20
-over the ?y parameter, to get=20
+The argument above suggests that we *must* generalise
+over the ?y parameter, to get
z :: (?y::Int) => Int,
but the monomorphism restriction says that we *must not*, giving
- z :: Int. =20
+ z :: Int.
Why does the momomorphism restriction say this? Because if you have
let z = x + ?y in z+z
then inlining 'z' might change the semantics of the program.
Choice (C) really says "the monomorphism restriction doesn't apply
-to implicit parameters". Which is fine, but remember that every=20
+to implicit parameters". Which is fine, but remember that every
innocent binding 'x = ...' that mentions an implicit parameter in
the RHS becomes a *function* of that parameter, called at each
use of 'x'. Now, the chances are that there are no intervening 'with'
-clauses that bind ?y, so a decent compiler should common up all=20
+clauses that bind ?y, so a decent compiler should common up all
those function calls. So I think I strongly favour (C). Indeed,
one could make a similar argument for abolishing the monomorphism
restriction altogether.
import RnHsSyn ( RenamedHsExpr )
-import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch )
+import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch, placeHolderType )
import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
mkTyVarTys, mkForAllTys, mkTyConApp,
genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
(g1:g2:g3:_) = genericNames
-mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing builtinSrcLoc))
+mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
idEP :: EP RenamedHsExpr
idEP = EP idexpr idexpr
projects / ghc-hetmet.git / commitdiff