Commit ab46fd8e authored by simonpj's avatar simonpj

[project @ 2001-07-12 16:21:22 by simonpj]

--------------------------------------------
	Fix another bug in the squash-newtypes story.
	--------------------------------------------

[This one was spotted by Marcin, and is now enshrined in test tc130.]

The desugarer straddles the boundary between the type checker and
Core, so it sometimes needs to look through newtypes/implicit parameters
and sometimes not.  This is really a bit painful, but I can't think of
a better way to do it.

The only simple way to fix things was to pass a bit more type
information in the HsExpr type, from the type checker to the desugarer.
That led to the non-local changes you can see.

On the way I fixed one other thing.  In various HsSyn constructors
there is a Type that is bogus (bottom) before the type checker, and
filled in with a real type by the type checker.  In one place it was
a (Maybe Type) which was Nothing before, and (Just ty) afterwards.
I've defined a type synonym HsTypes.PostTcType for this, and a named
bottom value HsTypes.placeHolderType to use when you want the bottom
value.
parent 6d1815b0
......@@ -11,9 +11,8 @@ module Check ( check , ExhaustivePat ) where
import HsSyn
import TcHsSyn ( TypecheckedPat )
import TcHsSyn ( TypecheckedPat, outPatType )
import TcType ( tcTyConAppTyCon, tcTyConAppArgs )
import DsHsSyn ( outPatType )
import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet,
CanItFail(..), tidyLitPat, tidyNPat,
)
......
......@@ -25,12 +25,12 @@ import Maybes ( maybeToBool )
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,
......@@ -152,6 +152,7 @@ unboxArg arg
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
......@@ -179,7 +180,9 @@ unboxArg arg
= 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
......@@ -187,7 +190,7 @@ unboxArg arg
(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}
......@@ -212,7 +215,7 @@ boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr)
-- 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
......@@ -282,7 +285,7 @@ touchzh = mkPrimOpId TouchOp
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,
......@@ -294,20 +297,22 @@ resultWrapper :: Type
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
......@@ -318,8 +323,5 @@ resultWrapper result_ty
| 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}
......@@ -15,9 +15,16 @@ import HsSyn ( failureFreePat,
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 )
......@@ -161,7 +168,9 @@ dsExpr (SectionL expr op)
= 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 ->
......@@ -175,7 +184,8 @@ dsExpr (SectionR op expr)
= 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 ->
......@@ -276,7 +286,7 @@ dsExpr (TyApp expr tys)
\underline{\bf Various data construction things}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
dsExpr (ExplicitListOut ty xs)
dsExpr (ExplicitList ty xs)
= go xs
where
go [] = returnDs (mkNilExpr ty)
......@@ -340,6 +350,8 @@ dsExpr (RecordConOut data_con con_expr rbinds)
= 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,
......@@ -382,10 +394,10 @@ might do some argument-evaluation first; and may have to throw away some
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' ->
......@@ -393,9 +405,8 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
-- 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,
......@@ -416,7 +427,7 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts 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
......@@ -474,7 +485,6 @@ dsExpr (DictApp expr dicts) -- becomes a curried application
#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
......@@ -511,13 +521,10 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
| 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])
......@@ -540,19 +547,19 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
= 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) ->
......
......@@ -27,19 +27,22 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
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
......@@ -120,7 +123,7 @@ dsFImport :: Module
-> 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)
......@@ -142,8 +145,8 @@ dsFImport mod_name fn_id (CDynImport cconv) = dsFExportDynamic mod_name fn_id cc
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) ->
......@@ -217,7 +220,7 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn
-- 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
......@@ -226,7 +229,7 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn
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)
......@@ -294,11 +297,11 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn
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'
......@@ -389,9 +392,9 @@ dsFExportDynamic mod_name id cconv
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
......@@ -448,7 +451,7 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
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
......@@ -496,7 +499,7 @@ showStgType t = text "Hs" <> text (showFFIType t)
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}
......@@ -14,7 +14,7 @@ import {-# SOURCE #-} Match ( matchSinglePat )
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
......@@ -49,7 +49,7 @@ dsGRHSs :: TypecheckedMatchContext -> [TypecheckedPat] -- These are to build a M
-> 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
......@@ -83,12 +83,12 @@ matchGuard [ResultStmt expr locn] ctx
-- 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)
......
......@@ -13,64 +13,6 @@ import TcHsSyn ( TypecheckedPat,
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}
......@@ -12,8 +12,7 @@ import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
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
......@@ -23,7 +22,7 @@ import CmdLineOpts ( opt_FoldrBuildOn )
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 )
......@@ -158,7 +157,7 @@ deListComp [ResultStmt expr locn] list -- Figure 7.4, SLPJ, p 135, rule C above
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)
......@@ -280,7 +279,7 @@ dfListComp c_id n_id [ResultStmt expr locn]
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))
......
......@@ -33,7 +33,7 @@ import Module ( Module )
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 )
......
......@@ -33,8 +33,7 @@ module DsUtils (
import {-# SOURCE #-} Match ( matchSimply )
import HsSyn
import TcHsSyn ( TypecheckedPat )
import DsHsSyn ( outPatType, collectTypedPatBinders )
import TcHsSyn ( TypecheckedPat, outPatType, collectTypedPatBinders )
import CoreSyn
import DsMonad
......@@ -46,8 +45,8 @@ import Id ( idType, Id, mkWildId )
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,
......@@ -269,8 +268,8 @@ mkCoAlgCaseMatchResult var match_alts
= 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
......@@ -620,4 +619,3 @@ mkFailurePair expr
\end{code}
......@@ -10,8 +10,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w
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 )
......@@ -23,7 +22,7 @@ import DataCon ( dataConFieldLabels, dataConInstOrigArgTys )
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
......@@ -416,7 +415,7 @@ tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result
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)
......
......@@ -17,7 +17,7 @@ import DsUtils
import Id ( Id )
import CoreSyn
import TcType ( mkTyVarTys )
import Type ( mkTyVarTys )
import ListSetOps ( equivClassesByUniq )
import Unique ( Uniquable(..) )
\end{code}
......
......@@ -21,7 +21,7 @@ import DsUtils
import Literal ( mkMachInt, Literal(..) )
import Maybes ( catMaybes )
import TcType ( isUnLiftedType )
import Type ( isUnLiftedType )
import Panic ( panic, assertPanic )
\end{code}
......
......@@ -10,6 +10,7 @@ module HsExpr where
-- friends:
import HsBinds ( HsBinds(..), nullBinds )
import HsTypes ( PostTcType )
import HsLit ( HsLit, HsOverLit )
import BasicTypes ( Fixity(..) )
import HsTypes ( HsType )
......@@ -95,9 +96,7 @@ data HsExpr id pat
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
......@@ -122,8 +121,9 @@ data HsExpr id pat
(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)
......@@ -146,7 +146,7 @@ data HsExpr 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
......@@ -300,9 +300,7 @@ ppr_expr (HsWith expr binds)
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)
......@@ -315,7 +313,7 @@ ppr_expr (RecordConOut data_con con rbinds)
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)
......@@ -381,8 +379,7 @@ pprParendExpr expr
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
......@@ -449,7 +446,7 @@ data Match id pat
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
......@@ -457,9 +454,9 @@ data GRHS id pat
-- 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]
......@@ -508,7 +505,7 @@ pprMatch ctxt (Match _ pats maybe_ty grhss)
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
......@@ -542,11 +539,12 @@ pp_rhs ctxt rhs = ptext (matchSeparator ctxt) <+> pprDeeper (ppr rhs)
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
......@@ -554,7 +552,7 @@ depends on the context. Consider the following contexts:
A do expression of type (m res_ty)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* ExprStmt E: do { ....; E; ... }
* ExprStmt E any_ty: do { ....; E; ... }
E :: m any_ty
Translation: E >> ...
......@@ -564,7 +562,7 @@ depends on the context. Consider the following contexts:
A list comprehensions of type [elt_ty]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* ExprStmt E: [ .. | .... E ]
* ExprStmt E Bool: [ .. | .... E ]
[ .. | ..., E, ... ]
[ .. | .... | ..., E | ... ]
E :: Bool
......@@ -576,7 +574,7 @@ depends on the context. Consider the following contexts:
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 ...
......@@ -598,7 +596,7 @@ instance (Outputable id, Outputable pat) =>
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)
......
......@@ -8,7 +8,8 @@ module HsLit where
#include "HsVersions.h"
import Type ( Type )
import Type ( Type )
import HsTypes ( PostTcType )
import Outputable
import Ratio ( Rational )
\end{code}
......@@ -34,9 +35,9 @@ data HsLit
| 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
......
......@@ -11,7 +11,10 @@ module HsTypes (
, hsUsOnce, hsUsMany
, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
, hsTyVarName, hsTyVarNames, replaceTyVarName
, hsTyVarName, hsTyVarNames, replaceTyVarName,
-- Type place holder
PostTcType, placeHolderType,
-- Printing
, pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
......@@ -44,9 +47,32 @@ import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey
)
import FiniteMap
import Outputable
\end{code}
%************************************************************************
%* *
\subsection{Annotating the syntax}
%* *
%************************************************************************