Commit 9429d794 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge branch 'master' of http://darcs.haskell.org/ghc

parents be5cc2e3 3394d49a
......@@ -62,7 +62,7 @@ module BasicTypes(
EP(..),
HsBang(..), isBanged, isMarkedUnboxed,
HsBang(..), isBanged,
StrictnessMark(..), isMarkedStrict,
DefMethSpec(..),
......@@ -585,33 +585,26 @@ e.g. data T = MkT !Int !(Bool,Bool)
-------------------------
-- HsBang describes what the *programmer* wrote
-- This info is retained in the DataCon.dcStrictMarks field
data HsBang = HsNoBang
data HsBang = HsNoBang -- Lazy field
| HsStrict
| HsBang Bool -- Source-language '!' bang
-- True <=> also an {-# UNPACK #-} pragma
| HsUnpack -- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
| HsUnpackFailed -- An UNPACK pragma that we could not make
-- use of, because the type isn't unboxable;
-- equivalant to HsStrict except for checkValidDataCon
| HsNoUnpack -- {-# NOUNPACK #-} ! (GHC extension, meaning "strict but not unboxed")
| HsUnpack -- Definite commitment: this field is strict and unboxed
| HsStrict -- Definite commitment: this field is strict but not unboxed
deriving (Eq, Data, Typeable)
instance Outputable HsBang where
ppr HsNoBang = empty
ppr HsStrict = char '!'
ppr HsUnpack = ptext (sLit "{-# UNPACK #-} !")
ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !")
ppr HsNoUnpack = ptext (sLit "{-# NOUNPACK #-} !")
ppr (HsBang True) = ptext (sLit "{-# UNPACK #-} !")
ppr (HsBang False) = char '!'
ppr HsUnpack = ptext (sLit "Unpacked")
ppr HsStrict = ptext (sLit "SrictNotUnpacked")
isBanged :: HsBang -> Bool
isBanged HsNoBang = False
isBanged _ = True
isMarkedUnboxed :: HsBang -> Bool
isMarkedUnboxed HsUnpack = True
isMarkedUnboxed _ = False
-------------------------
-- StrictnessMark is internal only, used to indicate strictness
-- of the DataCon *worker* fields
......
This diff is collapsed.
......@@ -2,11 +2,10 @@
module DataCon where
import Name( Name )
import {-# SOURCE #-} TyCon( TyCon )
import {-# SOURCE #-} TypeRep (Type)
data DataCon
data DataConRep
dataConName :: DataCon -> Name
dataConRepArgTys :: DataCon -> [Type]
dataConTyCon :: DataCon -> TyCon
isVanillaDataCon :: DataCon -> Bool
instance Eq DataCon
......
This diff is collapsed.
\begin{code}
module MkId where
import Name( Name )
import DataCon( DataCon, DataConIds )
import Var( Id )
import {-# SOURCE #-} DataCon( DataCon )
import {-# SOURCE #-} PrimOp( PrimOp )
import Id( Id )
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkPrimOpId :: PrimOp -> Id
data DataConBoxer
mkDataConWorkId :: Name -> DataCon -> Id
mkPrimOpId :: PrimOp -> Id
\end{code}
......@@ -519,9 +519,9 @@ repBangTy ty= do
rep2 strictTypeName [s, t]
where
(str, ty') = case ty of
L _ (HsBangTy HsUnpack ty) -> (unpackedName, ty)
L _ (HsBangTy _ ty) -> (isStrictName, ty)
_ -> (notStrictName, ty)
L _ (HsBangTy (HsBang True) ty) -> (unpackedName, ty)
L _ (HsBangTy _ ty) -> (isStrictName, ty)
_ -> (notStrictName, ty)
-------------------------------------------------------
-- Deriving clause
......
......@@ -316,10 +316,14 @@ mkCoAlgCaseMatchResult dflags var ty match_alts
mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
mk_alt fail (con, args, MatchResult _ body_fn) = do
body <- body_fn fail
us <- newUniqueSupply
return (mkReboxingAlt (uniqsFromSupply us) con args body)
mk_alt fail (con, args, MatchResult _ body_fn)
= do { body <- body_fn fail
; case dataConBoxer con of {
Nothing -> return (DataAlt con, args, body) ;
Just (DCB boxer) ->
do { us <- newUniqueSupply
; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
; return (DataAlt con, rep_ids, mkLets binds body) } } }
mk_default fail | exhaustive_case = []
| otherwise = [(DEFAULT, [], fail)]
......
......@@ -345,9 +345,9 @@ cvtConstr (ForallC tvs ctxt con)
, con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
cvt_arg (NotStrict, ty) = cvtType ty
cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsUnpack ty' }
cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang False) ty' }
cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang True) ty' }
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
cvt_id_arg (i, str, ty)
......
......@@ -749,19 +749,20 @@ instance Binary InlineSpec where
_ -> return NoInline
instance Binary HsBang where
put_ bh HsNoBang = putByte bh 0
put_ bh HsStrict = putByte bh 1
put_ bh HsUnpack = putByte bh 2
put_ bh HsUnpackFailed = putByte bh 3
put_ bh HsNoUnpack = putByte bh 4
put_ bh HsNoBang = putByte bh 0
put_ bh (HsBang False) = putByte bh 1
put_ bh (HsBang True) = putByte bh 2
put_ bh HsUnpack = putByte bh 3
put_ bh HsStrict = putByte bh 4
get bh = do
h <- getByte bh
case h of
0 -> do return HsNoBang
1 -> do return HsStrict
2 -> do return HsUnpack
3 -> do return HsUnpackFailed
_ -> do return HsNoUnpack
1 -> do return (HsBang False)
2 -> do return (HsBang True)
3 -> do return HsUnpack
_ -> do return HsStrict
instance Binary TupleSort where
put_ bh BoxedTuple = putByte bh 0
......
......@@ -39,6 +39,7 @@ import Coercion
import DynFlags
import TcRnMonad
import UniqSupply
import Util
import Outputable
\end{code}
......@@ -155,14 +156,17 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
-- code, which (for Haskell source anyway) will be in the DataName name
-- space, and puts it into the VarName name space
; us <- newUniqueSupply
; dflags <- getDynFlags
; let
stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
data_con = mkDataCon src_name declared_infix
arg_stricts field_lbls
univ_tvs ex_tvs eq_spec ctxt
arg_tys res_ty rep_tycon
stupid_ctxt dc_ids
dc_ids = mkDataConIds wrap_name work_name data_con
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dflags wrap_name data_con)
; return data_con }
......
......@@ -1505,7 +1505,7 @@ tyConToIfaceDecl env tycon
ifConArgTys = map (tidyToIfaceType env2) arg_tys,
ifConFields = map getOccName
(dataConFieldLabels data_con),
ifConStricts = dataConStrictMarks data_con }
ifConStricts = dataConRepBangs data_con }
where
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
......
......@@ -272,7 +272,7 @@ data GeneralFlag
| Opt_DoEtaReduction
| Opt_CaseMerge
| Opt_UnboxStrictFields
| Opt_UnboxStrictPrimitiveFields
| Opt_UnboxSmallStrictFields
| Opt_DictsCheap
| Opt_EnableRewriteRules -- Apply rewrite rules during simplification
| Opt_Vectorise
......@@ -2400,7 +2400,7 @@ fFlags = [
( "do-eta-reduction", Opt_DoEtaReduction, nop ),
( "case-merge", Opt_CaseMerge, nop ),
( "unbox-strict-fields", Opt_UnboxStrictFields, nop ),
( "unbox-strict-primitive-fields", Opt_UnboxStrictPrimitiveFields, nop ),
( "unbox-small-strict-fields", Opt_UnboxSmallStrictFields, nop ),
( "dicts-cheap", Opt_DictsCheap, nop ),
( "excess-precision", Opt_ExcessPrecision, nop ),
( "eager-blackholing", Opt_EagerBlackHoling, nop ),
......
......@@ -29,10 +29,12 @@ import GHC ( TyThing(..) )
import DataCon
import Id
import TyCon
import BasicTypes
import Coercion( pprCoAxiom )
import HscTypes( tyThingParent_maybe )
import TcType
import Name
import StaticFlags( opt_PprStyle_Debug )
import Outputable
import FastString
......@@ -203,7 +205,7 @@ pprDataConDecl pefas ss gadt_style dataCon
(arg_tys, res_ty) = tcSplitFunTys tau
labels = GHC.dataConFieldLabels dataCon
stricts = GHC.dataConStrictMarks dataCon
tys_w_strs = zip stricts arg_tys
tys_w_strs = zip (map user_ify stricts) arg_tys
pp_foralls | pefas = GHC.pprForAll forall_tvs
| otherwise = empty
......@@ -211,11 +213,17 @@ pprDataConDecl pefas ss gadt_style dataCon
add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty
pprParendBangTy (bang,ty) = ppr bang <> GHC.pprParendType ty
pprBangTy (bang,ty) = ppr bang <> ppr ty
pprBangTy bang ty = ppr bang <> ppr ty
-- See Note [Printing bangs on data constructors]
user_ify :: HsBang -> HsBang
user_ify bang | opt_PprStyle_Debug = bang
user_ify HsStrict = HsBang False
user_ify HsUnpack = HsBang True
user_ify bang = bang
maybe_show_label (lbl,(strict,tp))
| showSub ss lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp)
maybe_show_label (lbl,bty)
| showSub ss lbl = Just (ppr lbl <+> dcolon <+> pprBangTy bty)
| otherwise = Nothing
ppr_fields [ty1, ty2]
......@@ -290,3 +298,11 @@ showWithLoc loc doc
where
comment = ptext (sLit "--")
{-
Note [Printing bangs on data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For imported data constructors the dataConStrictMarks are the
representation choices (see Note [Bangs on data constructor arguments]
in DataCon.lhs). So we have to fiddle a little bit here to turn them
back into user-printable form.
-}
......@@ -1005,9 +1005,9 @@ infixtype :: { LHsType RdrName }
| btype tyvarop type { LL $ mkHsOpTy $1 $2 $3 }
strict_mark :: { Located HsBang }
: '!' { L1 HsStrict }
| '{-# UNPACK' '#-}' '!' { LL HsUnpack }
| '{-# NOUNPACK' '#-}' '!' { LL HsNoUnpack }
: '!' { L1 (HsBang False) }
| '{-# UNPACK' '#-}' '!' { LL (HsBang True) }
| '{-# NOUNPACK' '#-}' '!' { LL HsStrict }
-- A ctype is a for-all type
ctype :: { LHsType RdrName }
......
......@@ -281,8 +281,6 @@ basicKnownKeyNames
randomClassName, randomGenClassName, monadPlusClassName,
-- Type-level naturals
typeNatKindConName,
typeStringKindConName,
singIClassName,
typeNatLeqClassName,
typeNatAddTyFamName,
......@@ -1089,12 +1087,8 @@ randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey
isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey
-- Type-level naturals
typeNatKindConName, typeStringKindConName,
singIClassName, typeNatLeqClassName,
singIClassName, typeNatLeqClassName,
typeNatAddTyFamName, typeNatMulTyFamName, typeNatExpTyFamName :: Name
typeNatKindConName = tcQual gHC_TYPELITS (fsLit "Nat") typeNatKindConNameKey
typeStringKindConName = tcQual gHC_TYPELITS (fsLit "Symbol")
typeStringKindConNameKey
singIClassName = clsQual gHC_TYPELITS (fsLit "SingI") singIClassNameKey
typeNatLeqClassName = clsQual gHC_TYPELITS (fsLit "<=") typeNatLeqClassNameKey
typeNatAddTyFamName = tcQual gHC_TYPELITS (fsLit "+") typeNatAddTyFamNameKey
......
......@@ -34,7 +34,6 @@ module TysPrim(
-- Kinds
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind,
mkArrowKind, mkArrowKinds,
typeNatKind, typeStringKind,
funTyCon, funTyConName,
primTyCons,
......@@ -344,12 +343,6 @@ unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
openTypeKind = kindTyConType openTypeKindTyCon
constraintKind = kindTyConType constraintKindTyCon
typeNatKind :: Kind
typeNatKind = kindTyConType (mkKindTyCon typeNatKindConName superKind)
typeStringKind :: Kind
typeStringKind = kindTyConType (mkKindTyCon typeStringKindConName superKind)
-- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
mkArrowKind :: Kind -> Kind -> Kind
mkArrowKind k1 k2 = FunTy k1 k2
......
......@@ -64,6 +64,9 @@ module TysWiredIn (
-- * Unit
unitTy,
-- * Kinds
typeNatKindCon, typeNatKind, typeStringKindCon, typeStringKind,
-- * Parallel arrays
mkPArrTy,
parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
......@@ -76,7 +79,7 @@ module TysWiredIn (
#include "HsVersions.h"
import {-# SOURCE #-} MkId( mkDataConIds )
import {-# SOURCE #-} MkId( mkDataConWorkId )
-- friends:
import PrelNames
......@@ -148,6 +151,8 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
, listTyCon
, parrTyCon
, eqTyCon
, typeNatKindCon
, typeStringKindCon
]
++ (case cIntegerLibraryType of
IntegerGMP -> [integerTyCon]
......@@ -193,6 +198,11 @@ floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floa
doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon
doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon
-- Kinds
typeNatKindConName, typeStringKindConName :: Name
typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Nat") typeNatKindConNameKey typeNatKindCon
typeStringKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Symbol") typeStringKindConNameKey typeStringKindCon
-- For integer-gmp only:
integerRealTyConName :: Name
integerRealTyConName = case cIntegerLibraryType of
......@@ -277,16 +287,33 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
tycon
[] -- No stupid theta
(mkDataConIds bogus_wrap_name wrk_name data_con)
(mkDataConWorkId wrk_name data_con)
NoDataConRep -- Wired-in types are too simple to need wrappers
modu = ASSERT( isExternalName dc_name )
nameModule dc_name
wrk_occ = mkDataConWorkerOcc (nameOccName dc_name)
wrk_name = mkWiredInName modu wrk_occ wrk_key
(AnId (dataConWorkId data_con)) UserSyntax
bogus_wrap_name = pprPanic "Wired-in data wrapper id" (ppr dc_name)
-- Wired-in types are too simple to need wrappers
\end{code}
%************************************************************************
%* *
Kinds
%* *
%************************************************************************
\begin{code}
typeNatKindCon, typeStringKindCon :: TyCon
-- data Nat
-- data Symbol
typeNatKindCon = pcNonRecDataTyCon typeNatKindConName Nothing [] []
typeStringKindCon = pcNonRecDataTyCon typeStringKindConName Nothing [] []
typeNatKind, typeStringKind :: Kind
typeNatKind = TyConApp (promoteTyCon typeNatKindCon) []
typeStringKind = TyConApp (promoteTyCon typeStringKindCon) []
\end{code}
......
......@@ -6,5 +6,6 @@ import {-# SOURCE #-} TypeRep (Type)
eqTyCon :: TyCon
typeNatKind, typeStringKind :: Type
mkBoxedTupleTy :: [Type] -> Type
\end{code}
......@@ -19,20 +19,21 @@ import CoreSyn
import CoreUtils ( exprType )
import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
isOneShotLambda, setOneShotLambda, setIdUnfolding,
setIdInfo
setIdInfo, setIdType
)
import IdInfo ( vanillaIdInfo )
import DataCon
import Demand ( Demand(..), DmdResult(..), Demands(..) )
import MkCore ( mkRuntimeErrorApp, aBSENT_ERROR_ID )
import MkId ( realWorldPrimId, voidArgId,
mkUnpackCase, mkProductBox )
import MkId ( realWorldPrimId, voidArgId
, wrapNewTypeBody, unwrapNewTypeBody )
import TysPrim ( realWorldStatePrimTy )
import TysWiredIn ( tupleCon )
import Type
import Coercion ( mkSymCo, splitNewTypeRepCo_maybe )
import Coercion ( mkSymCo, instNewTyCon_maybe, splitNewTypeRepCo_maybe )
import BasicTypes ( TupleSort(..) )
import Literal ( absentLiteralOf )
import TyCon
import UniqSupply
import Unique
import Util ( zipWithEqual )
......@@ -416,6 +417,62 @@ nop_fn body = body
\end{code}
\begin{code}
mkUnpackCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
-- (mkUnpackCase x e args Con body)
-- returns
-- case (e `cast` ...) of bndr { Con args -> body }
--
-- the type of the bndr passed in is irrelevent
mkUnpackCase bndr arg unpk_args boxing_con body
= Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
where
(cast_arg, bndr_ty) = go (idType bndr) arg
go ty arg
| (tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty
, isNewTyCon tycon && not (isRecursiveTyCon tycon)
= go (newTyConInstRhs tycon tycon_args)
(unwrapNewTypeBody tycon tycon_args arg)
| otherwise = (arg, ty)
mkProductBox :: [Id] -> Type -> CoreExpr
mkProductBox arg_ids ty
= result_expr
where
(tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty
result_expr
| isNewTyCon tycon && not (isRecursiveTyCon tycon)
= wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args))
| otherwise = mkConApp pack_con (map Type tycon_args ++ varsToCoreExprs arg_ids)
wrap expr = wrapNewTypeBody tycon tycon_args expr
-- | As 'splitProductType_maybe', but in turn instantiates the 'TyCon' returned
-- and hence recursively tries to unpack it as far as it able to
deepSplitProductType_maybe :: Type -> Maybe (TyCon, [Type], DataCon, [Type])
deepSplitProductType_maybe ty
= do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
; let {result
| Just (ty', _co) <- instNewTyCon_maybe tycon tycon_args
, not (isRecursiveTyCon tycon)
= deepSplitProductType_maybe ty' -- Ignore the coercion?
| isNewTyCon tycon = Nothing -- cannot unbox through recursive
-- newtypes nor through families
| otherwise = Just res}
; result
}
-- | As 'deepSplitProductType_maybe', but panics if the 'Type' is not a product type
deepSplitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
deepSplitProductType str ty
= case deepSplitProductType_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
\end{code}
%************************************************************************
%* *
\subsection{CPR stuff}
......
......@@ -47,7 +47,6 @@ import Platform
import SrcLoc
import Bag
import FastString
import Util
import Control.Monad
\end{code}
......@@ -213,11 +212,11 @@ tcFImport d = pprPanic "tcFImport" (ppr d)
tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh l@(CLabel _))
= ASSERT( null arg_tys )
do checkCg checkCOrAsmOrLlvmOrInterp
-- Foreign import label
= do checkCg checkCOrAsmOrLlvmOrInterp
-- NB check res_ty not sig_ty!
-- In case sig_ty is (forall a. ForeignPtr a)
check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
check (null arg_tys && isFFILabelTy res_ty) (illegalForeignLabelErr sig_ty)
cconv' <- checkCConv cconv
return (CImport cconv' safety mh l)
......@@ -483,6 +482,11 @@ check :: Bool -> MsgDoc -> TcM ()
check True _ = return ()
check _ the_err = addErrTc the_err
illegalForeignLabelErr :: Type -> SDoc
illegalForeignLabelErr ty
= vcat [ illegalForeignTyErr empty ty
, ptext (sLit "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") ]
illegalForeignTyErr :: SDoc -> Type -> SDoc
illegalForeignTyErr arg_or_res ty
= hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
......
......@@ -504,12 +504,15 @@ tc_hs_type ty@(HsSpliceTy {}) _exp_kind
tc_hs_type (HsWrapTy {}) _exp_kind
= panic "tc_hs_type HsWrapTy" -- We kind checked something twice
tc_hs_type hs_ty@(HsTyLit tl) exp_kind = do
let (ty,k) = case tl of
HsNumTy n -> (mkNumLitTy n, typeNatKind)
HsStrTy s -> (mkStrLitTy s, typeStringKind)
checkExpectedKind hs_ty k exp_kind
return ty
tc_hs_type hs_ty@(HsTyLit (HsNumTy n)) exp_kind
= do { checkExpectedKind hs_ty typeNatKind exp_kind
; checkWiredInTyCon typeNatKindCon
; return (mkNumLitTy n) }
tc_hs_type hs_ty@(HsTyLit (HsStrTy s)) exp_kind
= do { checkExpectedKind hs_ty typeStringKind exp_kind
; checkWiredInTyCon typeStringKindCon
; return (mkStrLitTy s) }
---------------------------
tc_tuple :: HsType Name -> HsTupleSort -> [LHsType Name] -> ExpKind -> TcM TcType
......
......@@ -612,16 +612,15 @@ tcFamInstDecl1 fam_tc
; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc)
; stupid_theta <- tcHsContext ctxt
; dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
; h98_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
-- Construct representation tycon
; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc
; let ex_ok = True -- Existentials ok for type families!
orig_res_ty = mkTyConApp fam_tc pats'
; let orig_res_ty = mkTyConApp fam_tc pats'
; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
do { data_cons <- tcConDecls new_or_data ex_ok rec_rep_tc
do { data_cons <- tcConDecls new_or_data rec_rep_tc
(tvs', orig_res_ty) cons
; tc_rhs <- case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
......@@ -641,10 +640,6 @@ tcFamInstDecl1 fam_tc
-- Remember to check validity; no recursion to worry about here
; checkValidTyCon rep_tc
; return fam_inst } }
where
h98_syntax = case cons of -- All constructors have same shape
L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
_ -> True
----------------
......
This diff is collapsed.
......@@ -398,7 +398,9 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs
inst_axiom = famInstAxiom fam_inst
(fam, tys) = famInstLHS fam_inst
skol_tys = mkTyVarTys skol_tvs
tys1 = substTys (zipTopTvSubst (coAxiomTyVars inst_axiom) skol_tys) tys
ax_tvs = coAxiomTyVars inst_axiom
tys1 = ASSERT2( length ax_tvs == length skol_tys, ppr inst_axiom $$ ppr skol_tys )
substTys (zipTopTvSubst ax_tvs skol_tys) tys
-- In example above, fam tys' = F [b]
my_unify old_fam_inst tpl_tvs tpl_tys match_tys
......
......@@ -17,7 +17,6 @@ module Kind (
-- Kinds
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind,
mkArrowKind, mkArrowKinds,
typeNatKind, typeStringKind,
-- Kind constructors...
anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon,
......
......@@ -53,7 +53,6 @@ module TyCon(
isTyConAssoc, tyConAssoc_maybe,
isRecursiveTyCon,
isImplicitTyCon,
isEmptyDataTyCon,
-- ** Extracting information out of TyCons
tyConName,
......@@ -73,7 +72,6 @@ module TyCon(
algTyConRhs,
newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe,
tupleTyConBoxity, tupleTyConSort, tupleTyConArity,
tyConSingleFieldDataCon_maybe,
-- ** Manipulating TyCons
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
......@@ -90,7 +88,7 @@ module TyCon(
#include "HsVersions.h"
import {-# SOURCE #-} TypeRep ( Kind, Type, PredType )
import {-# SOURCE #-} DataCon ( DataCon, dataConRepArgTys, isVanillaDataCon )
import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon )
import Var
import Class
......@@ -1076,18 +1074,6 @@ isDataTyCon (AlgTyCon {algTcRhs = rhs})
isDataTyCon (TupleTyCon {tyConTupleSort = sort}) = isBoxed (tupleSortBoxity sort)
isDataTyCon _ = False
isEmptyDataTyCon :: TyCon -> Bool
isEmptyDataTyCon (AlgTyCon {algTcRhs = DataTyCon { data_cons = [data_con] } })
= isEmptyDataCon data_con
isEmptyDataTyCon (TupleTyCon {dataCon = data_con })
= isEmptyDataCon data_con
isEmptyDataTyCon _ = False
isEmptyDataCon :: DataCon -> Bool
isEmptyDataCon data_con = case dataConRepArgTys data_con of
[] -> True
_ -> False
-- | 'isDistinctTyCon' is true of 'TyCon's that are equal only to
-- themselves, even via coercions (except for unsafeCoerce).
-- This excludes newtypes, type functions, type synonyms.
......@@ -1142,27 +1128,6 @@ isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of
isProductTyCon (TupleTyCon {}) = True
isProductTyCon _ = False
-- | If the given 'TyCon' has a /single/ data constructor with a /single/ field,
-- i.e. it is a @data@ type with one alternative and one field, or a @newtype@
-- then the type of that field is returned. If the 'TyCon' has a single
-- constructor with more than one field, more than one constructor, or
-- represents a primitive or function type constructor then @Nothing@ is
-- returned. In any other case, the function panics
tyConSingleFieldDataCon_maybe :: TyCon -> Maybe Type
tyConSingleFieldDataCon_maybe tc@(AlgTyCon {}) = case algTcRhs tc of
DataTyCon{ data_cons = [data_con] }
| isVanillaDataCon data_con -> case dataConRepArgTys data_con of
[ty] -> Just ty
_ -> Nothing
| otherwise -> Nothing
NewTyCon { data_con = data_con }
-> case dataConRepArgTys data_con of
[ty] -> Just ty
_ -> pprPanic "tyConSingleFieldDataCon_maybe"
(ppr $ dataConRepArgTys data_con)
_ -> Nothing
tyConSingleFieldDataCon_maybe _ = Nothing
-- | Is this a 'TyCon' representing a type synonym (@type@)?
isSynTyCon :: TyCon -> Bool
isSynTyCon (SynTyCon {}) = True
......
......@@ -152,7 +152,7 @@ import VarSet
import Class
import TyCon
import TysPrim
import {-# SOURCE #-} TysWiredIn ( eqTyCon )
import {-# SOURCE #-} TysWiredIn ( eqTyCon, typeNatKind, typeStringKind )
import PrelNames ( eqTyConKey, ipClassNameKey,
constraintKindTyConKey, liftedTypeKindTyConKey )
......@@ -1034,7 +1034,9 @@ mkFamilyTyConApp :: TyCon -> [Type] -> Type
-- > mkFamilyTyConApp :RTL Int = T (Maybe Int)
mkFamilyTyConApp tc tys
| Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
, let fam_subst = zipTopTvSubst (tyConTyVars tc) tys
, let tvs = tyConTyVars tc
fam_subst = ASSERT2( length tvs == length tys, ppr tc <+> ppr tys )
zipTopTvSubst tvs tys
= mkTyConApp fam_tc (substTys fam_subst fam_tys)
| otherwise
= mkTyConApp tc tys
......@@ -1615,13 +1617,11 @@ typeKind _ty@(FunTy _arg res)
where
k = typeKind res
typeLiteralKind :: TyLit -> Kind
typeLiteralKind l =
case l of
NumTyLit _ -> typeNatKind
StrTyLit _ -> typeStringKind
\end{code}
Kind inference
......
......@@ -788,12 +788,6 @@
<entry>dynamic</entry>
<entry><option>-XTraditionalRecordSyntax</option></entry>
</row>
<row>
<entry><option>-XNoMonoPatBinds</option></entry>
<entry>Make <link linkend="monomorphism">pattern bindings polymorphic</link></entry>
<entry>dynamic</entry>
<entry><option>-XMonoPatBinds</option></entry>
</row>
<row>
<entry><option>-XRelaxedPolyRec</option></entry>
<entry>Relaxed checking for <link linkend="typing-binds">mutually-recursive polymorphic functions</link></entry>
......@@ -862,6 +856,7 @@