diff options
38 files changed, 258 insertions, 65 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 93a1dc1e52..f1318c1dc9 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -1,14 +1,6 @@ -- Cmm representations using Hoopl's Graph CmmNode e x. {-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} #if __GLASGOW_HASKELL__ >= 703 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs @@ -137,7 +129,7 @@ data ProfilingInfo -- we add a label for the table, and expect only the 'offset/length' form data C_SRT = NoC_SRT - | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-} + | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-} deriving (Eq) needsSRT :: C_SRT -> Bool diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index ac047edb89..682d76096b 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -1099,8 +1099,15 @@ getTyDescription ty FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon ForAllTy _ ty -> getTyDescription ty + LiteralTy n -> getTyLitDescription n } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other + + +getTyLitDescription :: TyLit -> String +getTyLitDescription l = + case l of + NumberTyLit n -> show n \end{code} diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 5c0741a65e..d40ff9e1e5 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -864,11 +864,17 @@ getTyDescription ty FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon ForAllTy _ ty -> getTyDescription ty + LiteralTy n -> getTyLitDescription n } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other +getTyLitDescription :: TyLit -> String +getTyLitDescription l = + case l of + NumberTyLit n -> show n + -------------------------------------- -- CmmInfoTable-related things -------------------------------------- diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index fa22e7efea..984e08b8f9 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -846,10 +846,20 @@ lintType ty@(TyConApp tc tys) | otherwise = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) +lintType ty@(LiteralTy l) = lintTyLit l >> return (typeKind ty) + lintType (ForAllTy tv ty) = do { lintTyBndrKind tv ; addInScopeVar tv (lintType ty) } +--- + +lintTyLit :: TyLit -> LintM () +lintTyLit (NumberTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = ptext (sLit "Negative type literal:") <+> integer n + ---------------- lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind lint_ty_app ty k tys = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index d8a134ed87..e6779b7850 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -486,7 +486,10 @@ data TypeMap a , tm_app :: TypeMap (TypeMap a) , tm_fun :: TypeMap (TypeMap a) , tm_tc_app :: NameEnv (ListMap TypeMap a) - , tm_forall :: TypeMap (BndrMap a) } + , tm_forall :: TypeMap (BndrMap a) + , tm_tylit :: TyLitMap a + } + instance Outputable a => Outputable (TypeMap a) where ppr m = text "TypeMap elts" <+> ppr (foldTypeMap (:) [] m) @@ -499,7 +502,8 @@ wrapEmptyTypeMap = TM { tm_var = emptyTM , tm_app = EmptyTM , tm_fun = EmptyTM , tm_tc_app = emptyNameEnv - , tm_forall = EmptyTM } + , tm_forall = EmptyTM + , tm_tylit = emptyTyLitMap } instance TrieMap TypeMap where type Key TypeMap = Type @@ -519,6 +523,7 @@ lkT env ty m go (AppTy t1 t2) = tm_app >.> lkT env t1 >=> lkT env t2 go (FunTy t1 t2) = tm_fun >.> lkT env t1 >=> lkT env t2 go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys + go (LiteralTy l) = tm_tylit >.> lkTyLit l go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv ----------------- @@ -535,6 +540,8 @@ xtT env (ForAllTy tv ty) f m = m { tm_forall = tm_forall m |> xtT (extendCME e xtT env (TyConApp tc tys) f m = m { tm_tc_app = tm_tc_app m |> xtNamed tc |>> xtList (xtT env) tys f } +xtT _ (LiteralTy l) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } + fdT :: (a -> b -> b) -> TypeMap a -> b -> b fdT _ EmptyTM = \z -> z fdT k m = foldTM k (tm_var m) @@ -542,6 +549,29 @@ fdT k m = foldTM k (tm_var m) . foldTM (foldTM k) (tm_fun m) . foldTM (foldTM k) (tm_tc_app m) . foldTM (foldTM k) (tm_forall m) + . foldTyLit k (tm_tylit m) + + + +------------------------ +data TyLitMap a = TLM { tlm_number :: Map.Map Integer a } + +emptyTyLitMap :: TyLitMap a +emptyTyLitMap = TLM { tlm_number = Map.empty } + +lkTyLit :: TyLit -> TyLitMap a -> Maybe a +lkTyLit l = + case l of + NumberTyLit n -> tlm_number >.> Map.lookup n + +xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a +xtTyLit l f m = + case l of + NumberTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n } + +foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b +foldTyLit l m x = Map.fold l x (tlm_number m) + \end{code} diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index accb3ddc14..aa96ed9f5e 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -181,6 +181,8 @@ data HsType name [PostTcKind] -- See Note [Promoted lists and tuples] [LHsType name] + | HsNumberTy Integer -- A promoted numeric literal. + | HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output deriving (Data, Typeable) @@ -566,6 +568,7 @@ ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys) ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys) +ppr_mono_ty _ (HsNumberTy n) = integer n ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty) = ppr_mono_ty ctxt_prec ty diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 792421daa5..15434f0473 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1037,6 +1037,10 @@ instance Binary IfaceType where put_ bh (IfaceTyConApp tc tys) = do { putByte bh 21; put_ bh tc; put_ bh tys } + put_ bh (IfaceLiteralTy n) + = do { putByte bh 30; put_ bh n } + + get bh = do h <- getByte bh case h of @@ -1076,8 +1080,21 @@ instance Binary IfaceType where 21 -> do { tc <- get bh; tys <- get bh ; return (IfaceTyConApp tc tys) } + 30 -> do n <- get bh + return (IfaceLiteralTy n) + _ -> panic ("get IfaceType " ++ show h) +instance Binary IfaceTyLit where + put_ bh (IfaceNumberTyLit n) = putByte bh 1 >> put_ bh n + + get bh = + do tag <- getByte bh + case tag of + 1 -> do { n <- get bh + ; return (IfaceNumberTyLit n) } + _ -> panic ("get IfaceTyLit " ++ show tag) + instance Binary IfaceTyCon where -- Int,Char,Bool can't show up here because they can't not be saturated put_ bh IfaceIntTc = putByte bh 1 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 6f59e38736..541f041589 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -808,6 +808,7 @@ freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& fnList freeNamesIfType ts +freeNamesIfType (IfaceLiteralTy _) = emptyNameSet freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 5441287eef..1565df1bc7 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -17,6 +17,7 @@ module IfaceType ( IfExtName, IfLclName, IfIPName, IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..), + IfaceTyLit(..), IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, ifaceTyConName, @@ -83,10 +84,14 @@ data IfaceType -- A kind of universal type, used for types, kinds, and coerci | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated -- Includes newtypes, synonyms, tuples | IfaceCoConApp IfaceCoCon [IfaceType] -- Always saturated + | IfaceLiteralTy IfaceTyLit type IfacePredType = IfaceType type IfaceContext = [IfacePredType] +data IfaceTyLit + = IfaceNumberTyLit Integer + data IfaceTyCon -- Encodes type constructors, kind constructors -- coercion constructors, the lot = IfaceTc IfExtName -- The common case @@ -241,6 +246,8 @@ ppr_ty :: Int -> IfaceType -> SDoc ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys +ppr_ty _ (IfaceLiteralTy n) = ppr_tylit n + ppr_ty ctxt_prec (IfaceCoConApp tc tys) = maybeParen ctxt_prec tYCON_PREC (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))]) @@ -302,6 +309,9 @@ ppr_tc :: IfaceTyCon -> SDoc ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (getOccName ext_nm) (ppr tc) ppr_tc tc = ppr tc +ppr_tylit :: IfaceTyLit -> SDoc +ppr_tylit (IfaceNumberTyLit n) = integer n + ------------------- instance Outputable IfaceTyCon where ppr (IfaceIPTc n) = ppr (IPName n) @@ -317,6 +327,9 @@ instance Outputable IfaceCoCon where ppr IfaceInstCo = ptext (sLit "Inst") ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d +instance Outputable IfaceTyLit where + ppr = ppr_tylit + ------------------- pprIfaceContext :: IfaceContext -> SDoc -- Prints "(C a, D b) =>", including the arrow @@ -362,6 +375,7 @@ toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2) toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) +toIfaceType (LiteralTy n) = IfaceLiteralTy (toIfaceTyLit n) toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) toIfaceTyVar :: TyVar -> FastString @@ -402,6 +416,9 @@ toIfaceWiredInTyCon tc nm | nm == tySuperKindTyConName = IfaceSuperKindTc | otherwise = IfaceTc nm +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceTyLit (NumberTyLit x) = IfaceNumberTyLit x + ---------------- toIfaceTypes :: [Type] -> [IfaceType] toIfaceTypes ts = map toIfaceType ts diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index a662d6abf3..e981995bd4 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -815,6 +815,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo tcIfaceType :: IfaceType -> IfL Type tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } +tcIfaceType (IfaceLiteralTy l) = do { l1 <- tcIfaceTyLit l; return (LiteralTy l1) } tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } @@ -826,6 +827,10 @@ tcIfaceTypes tys = mapM tcIfaceType tys ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType tcIfaceCtxt sts = mapM tcIfaceType sts + +----------------------------------------- +tcIfaceTyLit :: IfaceTyLit -> IfL TyLit +tcIfaceTyLit (IfaceNumberTyLit n) = return (NumberTyLit n) \end{code} %************************************************************************ @@ -840,6 +845,7 @@ tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts +tcIfaceCo t@(IfaceLiteralTy _) = mkReflCo <$> tcIfaceType t tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> mkForAllCo tv' <$> tcIfaceCo t diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 8a41fa4983..6e75793962 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1069,6 +1069,7 @@ atype :: { LHsType RdrName } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) } | SIMPLEQUOTE '[' comma_types0 ']' { LL $ HsExplicitListTy placeHolderKind $3 } | '[' ctype ',' comma_types1 ']' { LL $ HsExplicitListTy placeHolderKind ($2 : $4) } + | INTEGER { LL $ HsNumberTy $ getINTEGER $1 } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 14778171f5..928eb03647 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -136,6 +136,7 @@ extract_lty (L loc ty) acc HsDocTy ty _ -> extract_lty ty acc HsExplicitListTy _ tys -> extract_ltys tys acc HsExplicitTupleTy _ tys -> extract_ltys tys acc + HsNumberTy _ -> acc HsWrapTy _ _ -> panic "extract_lty" extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName] diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index a3c2c6bb83..911402c59b 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -38,6 +38,7 @@ module TysPrim( anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind, mkArrowKind, mkArrowKinds, + typeNatKind, funTyCon, funTyConName, primTyCons, @@ -341,6 +342,11 @@ argTypeKind = kindTyConType argTypeKindTyCon ubxTupleKind = kindTyConType ubxTupleKindTyCon constraintKind = kindTyConType constraintKindTyCon + -- XXX: we should probably be using a different type than Word here... +typeNatKind :: Kind +typeNatKind = kindTyConType (mkKindTyCon wordTyConName tySuperKind) + + -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ mkArrowKind :: Kind -> Kind -> Kind mkArrowKind k1 k2 = FunTy k1 k2 diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index e2369bb776..43494bbded 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -88,6 +88,7 @@ extractHsTyNames ty -- but I don't think it matters get (HsExplicitListTy _ tys) = extractHsTyNames_s tys get (HsExplicitTupleTy _ tys) = extractHsTyNames_s tys + get (HsNumberTy _) = emptyNameSet get (HsWrapTy {}) = panic "extractHsTyNames" extractHsTyNames_s :: [LHsType Name] -> NameSet diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index df6008b574..936f38f55b 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -221,6 +221,13 @@ rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do tys' <- mapM (rnLHsTyKi isType doc) tys return (HsTupleTy tup_con tys') +-- 1. Perhaps we should use a separate extension here? +-- 2. Check that the integer is positive? +rnHsTyKi isType _ numberTy@(HsNumberTy n) = do + poly_kinds <- xoptM Opt_PolyKinds + unless (poly_kinds || isType) (addErr (polyKindsErr numberTy)) + return (HsNumberTy n) + rnHsTyKi isType doc (HsAppTy ty1 ty2) = do ty1' <- rnLHsTyKi isType doc ty1 ty2' <- rnLHsTyKi isType doc ty2 diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index d54294f4f3..d1c4ae3ad9 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -4,13 +4,6 @@ \section[StgLint]{A ``lint'' pass to check for Stg correctness} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgLint ( lintStgBindings ) where import StgSyn @@ -121,10 +114,10 @@ lint_binds_help (binder, rhs) (mkUnLiftedTyMsg binder rhs) -- Check match to RHS type - -- Actually we *can't* check the RHS type, because - -- unsafeCoerce means it really might not match at all - -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce... - -- case maybe_rhs_ty of + -- Actually we *can't* check the RHS type, because + -- unsafeCoerce means it really might not match at all + -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce... + -- case maybe_rhs_ty of -- Nothing -> return () -- Just rhs_ty -> checkTys binder_ty -- rhs_ty @@ -237,8 +230,8 @@ lintStgAlts alts scrut_ty = do return (Just first_ty) where -- check ty = checkTys first_ty ty (mkCaseAltMsg alts) - -- We can't check that the alternatives have the - -- same type, becuase they don't, with unsafeCoerce# + -- We can't check that the alternatives have the + -- same type, becuase they don't, with unsafeCoerce# lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type) lintAlt _ (DEFAULT, _, _, rhs) @@ -398,8 +391,8 @@ checkFunApp fun_ty arg_tys msg where (mb_ty, mb_msg) = cfa True fun_ty arg_tys - cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? - , Maybe Message) -- Errors? + cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? + , Maybe Message) -- Errors? cfa accurate fun_ty [] -- Args have run out; that's fine = (if accurate then Just fun_ty else Nothing, Nothing) @@ -446,12 +439,12 @@ stgEqType orig_ty1 orig_ty2 | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1 , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2 , let res = if tc1 == tc2 - then equalLength tc_args1 tc_args2 - && and (zipWith go tc_args1 tc_args2) - else -- TyCons don't match; but don't bleat if either is a - -- family TyCon because a coercion might have made it - -- equal to something else - (isFamilyTyCon tc1 || isFamilyTyCon tc2) + then equalLength tc_args1 tc_args2 + && and (zipWith go tc_args1 tc_args2) + else -- TyCons don't match; but don't bleat if either is a + -- family TyCon because a coercion might have made it + -- equal to something else + (isFamilyTyCon tc1 || isFamilyTyCon tc2) = if res then True else pprTrace "stgEqType: unequal" (vcat [ppr orig_ty1, ppr orig_ty2, ppr rep_ty1 @@ -459,7 +452,7 @@ stgEqType orig_ty1 orig_ty2 False | otherwise = True -- Conservatively say "fine". - -- Type variables in particular + -- Type variables in particular checkInScope :: Id -> LintM () checkInScope id = LintM $ \loc scope errs diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index dce91b1f02..480c1b16d9 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -602,6 +602,8 @@ flatten d ctxt ty = do { (xi, co) <- flatten d ctxt ty' ; return (xi,co) } +flatten _ _ xi@(LiteralTy _) = return (xi, mkTcReflCo xi) + flatten d ctxt (TyVarTy tv) = do { ieqs <- getInertEqs ; let mco = tv_eq_subst (fst ieqs) tv -- co : v ~ ty @@ -743,6 +745,7 @@ flatten d ctxt ty@(ForAllTy {}) where under_families tvs rho = go (mkVarSet tvs) rho where go _bound (TyVarTy _tv) = False + go _ (LiteralTy _) = False go bound (TyConApp tc tys) | isSynFamilyTyCon tc , (args,rest) <- splitAt (tyConArity tc) tys @@ -1427,6 +1430,8 @@ expandAway tv ty@(ForAllTy {}) expandAway tv ty@(TyConApp tc tys) = (mkTyConApp tc <$> mapM (expandAway tv) tys) <|> (tcView ty >>= expandAway tv) +expandAway _ xi@(LiteralTy _) = return xi + \end{code} Note [Type synonyms and canonicalization] diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 8e86afc5dd..5a24419ad2 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -686,6 +686,7 @@ quickFlattenTy :: TcType -> TcM TcType quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty' quickFlattenTy ty@(TyVarTy {}) = return ty quickFlattenTy ty@(ForAllTy {}) = return ty -- See +quickFlattenTy ty@(LiteralTy _) = return ty -- Don't flatten because of the danger or removing a bound variable quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1 ; fy2 <- quickFlattenTy ty2 diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 87aaa3238d..cb4c75cc6e 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -262,6 +262,7 @@ liftTcCoSubstWith tvs cos ty Nothing -> mkTcReflCo ty
go (AppTy t1 t2) = mkTcAppCo (go t1) (go t2)
go (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys)
+ go ty@(LiteralTy _) = mkTcReflCo ty
go (ForAllTy tv ty) = mkTcForAllCo tv (go ty)
go (FunTy t1 t2) = mkTcFunCo (go t1) (go t2)
\end{code}
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index c040d6d58f..2996ce954c 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -169,6 +169,9 @@ normaliseFfiType' env ty0 = go [] ty0 go _ ty@(TyVarTy _) = return (Refl ty, ty) + go _ ty@(LiteralTy _) + = return (Refl ty, ty) + add_co co rec_nts ty = do (co', ty') <- go rec_nts ty return (mkTransCo co co', ty') diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 218539d138..6efc1028e2 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -520,6 +520,10 @@ kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do checkExpectedKind ty tupleKi exp_kind return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s)) +kc_hs_type ty@(HsNumberTy n) exp_kind = do + checkExpectedKind ty typeNatKind exp_kind + return (HsNumberTy n) + kc_hs_type (HsWrapTy {}) _exp_kind = panic "kc_hs_type HsWrapTy" -- We kind checked something twice @@ -755,6 +759,8 @@ ds_type (HsExplicitTupleTy kis tys) = do tys' <- mapM dsHsType tys return $ mkTyConApp (buildPromotedDataTyCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') +ds_type (HsNumberTy n) = return (mkNumberTy n) + ds_type (HsWrapTy (WpKiApps kappas) ty) = do tau <- ds_type ty kappas' <- mapM zonkTcKindToKind kappas diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 2bbb2e11eb..852537223f 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -811,6 +811,8 @@ zonkType zonk_tc_tyvar ty go (TyConApp tc tys) = do tys' <- mapM go tys return (TyConApp tc tys') + go (LiteralTy n) = return (LiteralTy n) + go (FunTy arg res) = do arg' <- go arg res' <- go res return (FunTy arg' res') @@ -1079,6 +1081,8 @@ check_type rank ubx_tup ty@(TyConApp tc tys) arity_msg = arityErr "Type synonym" (tyConName tc) tc_arity n_args ubx_tup_msg = ubxArgTyErr ty +check_type _ _ (LiteralTy _) = return () + check_type _ _ ty = pprPanic "check_type" (ppr ty) ---------------------------------------- @@ -1744,6 +1748,7 @@ fvType :: Type -> [TyVar] fvType ty | Just exp_ty <- tcView ty = fvType exp_ty fvType (TyVarTy tv) = [tv] fvType (TyConApp _ tys) = fvTypes tys +fvType (LiteralTy _) = [] fvType (FunTy arg res) = fvType arg ++ fvType res fvType (AppTy fun arg) = fvType fun ++ fvType arg fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty) @@ -1756,6 +1761,7 @@ sizeType :: Type -> Int sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty sizeType (TyVarTy _) = 1 sizeType (TyConApp _ tys) = sizeTypes tys + 1 +sizeType (LiteralTy _) = 1 sizeType (FunTy arg res) = sizeType arg + sizeType res + 1 sizeType (AppTy fun arg) = sizeType fun + sizeType arg sizeType (ForAllTy _ ty) = sizeType ty diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index a36be651b4..511e47eb5c 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -896,6 +896,7 @@ floatEqualities skols can_given wantders | FlatSkol ty <- tcTyVarDetails tv = tvs_under_fsks ty | otherwise = unitVarSet tv tvs_under_fsks (TyConApp _ tys) = unionVarSets (map tvs_under_fsks tys) + tvs_under_fsks (LiteralTy _) = emptyVarSet tvs_under_fsks (FunTy arg res) = tvs_under_fsks arg `unionVarSet` tvs_under_fsks res tvs_under_fsks (AppTy fun arg) = tvs_under_fsks fun `unionVarSet` tvs_under_fsks arg tvs_under_fsks (ForAllTy tv ty) -- The kind of a coercion binder @@ -1378,4 +1379,4 @@ newFlatWanteds orig theta CNonCanonical { cc_id = v , cc_flavor = Wanted loc , cc_depth = 0 } } -\end{code}
\ No newline at end of file +\end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 37fa817ce6..5653a153ce 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1307,6 +1307,7 @@ reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `T reifyType ty@(FunTy t1 t2) | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } +reifyType (LiteralTy _) = failWith $ ptext $ sLit "Type-level literal canont be reifyed yet." reify_for_all :: TypeRep.Type -> TcM TH.Type reify_for_all ty diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index f5d880d8fa..8ac4ab8230 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -238,6 +238,7 @@ calcClassCycles cls = flip (foldr (expandType seen path)) tys expandType _ _ (TyVarTy _) = id + expandType _ _ (LiteralTy _) = id expandType seen path (AppTy t1 t2) = expandType seen path t1 . expandType seen path t2 expandType seen path (FunTy t1 t2) = expandType seen path t1 . expandType seen path t2 expandType seen path (ForAllTy _tv t) = expandType seen path t @@ -473,6 +474,7 @@ tcTyConsOfType ty go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim go ty | Just ty' <- tcView ty = go ty' go (TyVarTy _) = emptyNameEnv + go (LiteralTy _) = emptyNameEnv go (TyConApp tc tys) = go_tc tc tys go (AppTy a b) = go a `plusNameEnv` go b go (FunTy a b) = go a `plusNameEnv` go b diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index d4d2642315..808d538443 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -172,7 +172,9 @@ import TyCon -- others: import DynFlags -import Name hiding (varName) +import Name -- hiding (varName) + -- We use this to make dictionaries for type literals. + -- Perhaps there's a better way to do this? import NameSet import VarEnv import PrelNames @@ -499,6 +501,7 @@ tidyType env@(_, subst) ty Just tv' -> expand tv' go (TyConApp tycon tys) = let args = map go tys in args `seqList` TyConApp tycon args + go (LiteralTy n) = LiteralTy n go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) @@ -592,6 +595,7 @@ tcTyFamInsts (TyVarTy _) = [] tcTyFamInsts (TyConApp tc tys) | isSynFamilyTyCon tc = [(tc, tys)] | otherwise = concat (map tcTyFamInsts tys) +tcTyFamInsts (LiteralTy _) = [] tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 tcTyFamInsts (ForAllTy _ ty) = tcTyFamInsts ty @@ -641,6 +645,7 @@ exactTyVarsOfType ty go ty | Just ty' <- tcView ty = go ty' -- This is the key line go (TyVarTy tv) = unitVarSet tv go (TyConApp _ tys) = exactTyVarsOfTypes tys + go (LiteralTy _) = emptyVarSet go (FunTy arg res) = go arg `unionVarSet` go res go (AppTy fun arg) = go fun `unionVarSet` go arg go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar @@ -776,9 +781,13 @@ getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty' getDFunTyKey (TyVarTy tv) = getOccName tv getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (LiteralTy x) = getDFunTyLitKey x getDFunTyKey (AppTy fun _) = getDFunTyKey fun getDFunTyKey (FunTy _ _) = getOccName funTyCon getDFunTyKey (ForAllTy _ t) = getDFunTyKey t + +getDFunTyLitKey :: TyLit -> OccName +getDFunTyLitKey (NumberTyLit n) = mkOccName Name.varName (show n) \end{code} @@ -1168,6 +1177,7 @@ tcTyVarsOfType :: Type -> TcTyVarSet tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv else emptyVarSet tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys +tcTyVarsOfType (LiteralTy _) = emptyVarSet tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar @@ -1192,6 +1202,7 @@ orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty' orphNamesOfType (TyVarTy _) = emptyNameSet orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon `unionNameSets` orphNamesOfTypes tys +orphNamesOfType (LiteralTy _) = emptyNameSet orphNamesOfType (FunTy arg res) = orphNamesOfType arg `unionNameSets` orphNamesOfType res orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSets` orphNamesOfType arg orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 23de50af56..ffe9958c6d 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -615,7 +615,11 @@ uType_np origin orig_ty1 orig_ty2 | tc1 == tc2 -- See Note [TyCon app] = do { cos <- uList origin uType tys1 tys2 ; return $ mkTcTyConAppCo tc1 cos } - + + go (LiteralTy m) ty@(LiteralTy n) + | m == n + = return $ mkTcReflCo ty + -- See Note [Care with type applications] go (AppTy s1 t1) ty2 | Just (s2,t2) <- tcSplitAppTy_maybe ty2 @@ -912,6 +916,7 @@ checkTauTvUpdate tv ty = Just (TyConApp tc tys') | isSynTyCon tc, Just ty_expanded <- tcView this_ty = ok ty_expanded -- See Note [Type synonyms and the occur check] + ok ty@(LiteralTy _) = Just ty ok (FunTy arg res) | Just arg' <- ok arg, Just res' <- ok res = Just (FunTy arg' res') ok (AppTy fun arg) | Just fun' <- ok fun, Just arg' <- ok arg diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 840365ef78..6789bab913 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -919,6 +919,7 @@ ty_co_subst subst ty go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty) where (subst', v') = liftCoSubstTyVarBndr subst v + go ty@(LiteralTy _) = mkReflCo ty liftCoSubstTyVar :: LiftCoSubst -> TyVar -> Maybe Coercion liftCoSubstTyVar (LCS _ cenv) tv = lookupVarEnv cenv tv diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 236185168b..1f49842fab 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -578,6 +578,7 @@ normaliseType env ty | Just ty' <- coreView ty = normaliseType env ty' normaliseType env (TyConApp tc tys) = normaliseTcApp env tc tys +normaliseType _env ty@(LiteralTy _) = (Refl ty, ty) normaliseType env (AppTy ty1 ty2) = let (coi1,nty1) = normaliseType env ty1 (coi2,nty2) = normaliseType env ty2 diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index fa467a7f27..f2155803f4 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -18,6 +18,7 @@ module Kind ( anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind, mkArrowKind, mkArrowKinds, + typeNatKind, -- Kind constructors... anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index a344fd151b..a4f4252d74 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -41,6 +41,8 @@ module Type ( mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, mkPiKinds, mkPiType, mkPiTypes, applyTy, applyTys, applyTysD, isForAllTy, dropForAlls, + + mkLiteralTy, mkNumberTyLit, mkNumberTy, isNumberTy, -- (Newtypes) newTyConInstRhs, carefullySplitNewType_maybe, @@ -277,6 +279,7 @@ expandTypeSynonyms ty = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') | otherwise = TyConApp tc (map go tys) + go (LiteralTy l) = LiteralTy l go (TyVarTy tv) = TyVarTy tv go (AppTy t1 t2) = AppTy (go t1) (go t2) go (FunTy t1 t2) = FunTy (go t1) (go t2) @@ -403,6 +406,25 @@ splitAppTys ty = split ty ty [] \end{code} + LiteralTy + ~~~~~~~~~ + +\begin{code} +mkLiteralTy :: TyLit -> Type +mkLiteralTy = LiteralTy + +mkNumberTyLit :: Integer -> TyLit +mkNumberTyLit = NumberTyLit + +mkNumberTy :: Integer -> Type +mkNumberTy n = mkLiteralTy (mkNumberTyLit n) + +isNumberTy :: Type -> Maybe Integer +isNumberTy (LiteralTy (NumberTyLit n)) = Just n +isNumberTy _ = Nothing +\end{code} + + --------------------------------------------------------------------- FunTy ~~~~~ @@ -972,6 +994,7 @@ typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 typeSize (ForAllTy _ t) = 1 + typeSize t typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) +typeSize (LiteralTy _) = 1 varSetElemsKvsFirst :: VarSet -> [TyVar] -- {k1,a,k2,b} --> [k1,k2,a,b] @@ -1129,6 +1152,7 @@ seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty +seqType (LiteralTy n) = n `seq` () seqTypes :: [Type] -> () seqTypes [] = () @@ -1462,6 +1486,7 @@ subst_ty subst ty go (ForAllTy tv ty) = case substTyVarBndr subst tv of (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty) + go (LiteralTy n) = n `seq` LiteralTy n substTyVar :: TvSubst -> TyVar -> Type substTyVar (TvSubst _ tenv) tv @@ -1549,6 +1574,7 @@ typeKind (TyConApp tc tys) = kindAppResult (tyConKind tc) tys typeKind (AppTy fun arg) = kindAppResult (typeKind fun) [arg] +typeKind (LiteralTy l) = typeLiteralKind l typeKind (ForAllTy _ ty) = typeKind ty typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind (FunTy _arg res) @@ -1562,6 +1588,12 @@ typeKind (FunTy _arg res) where k = typeKind res + +typeLiteralKind :: TyLit -> Kind +typeLiteralKind l = + case l of + NumberTyLit _ -> typeNatKind + \end{code} Kind inference diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 26526abbf0..c830a12ac3 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -18,6 +18,7 @@ module TypeRep ( TyThing(..), Type(..), + TyLit(..), KindOrType, Kind, SuperKind, PredType, ThetaType, -- Synonyms @@ -29,7 +30,7 @@ module TypeRep ( pprType, pprParendType, pprTypeApp, pprTyThing, pprTyThingCategory, pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, + pprKind, pprParendKind, pprTyLit, Prec(..), maybeParen, pprTcApp, pprTypeNameApp, pprPrefixApp, pprArrowChain, ppr_type, @@ -112,8 +113,17 @@ data Type Var -- Type or kind variable Type -- ^ A polymorphic type + | LiteralTy TyLit -- ^ Type literals are simillar to type constructors. + deriving (Data.Data, Data.Typeable) + +-- NOTE: Other parts of the code assume that type literals do not contain +-- types or type variables. +data TyLit + = NumberTyLit Integer + deriving (Eq, Ord, Data.Data, Data.Typeable) + type KindOrType = Type -- See Note [Arguments to type constructors] -- | The key type representing kinds in the compiler. @@ -279,6 +289,7 @@ tyVarsOfType :: Type -> VarSet -- kind variable {k} tyVarsOfType (TyVarTy v) = unitVarSet v tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys +tyVarsOfType (LiteralTy _) = emptyVarSet tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar @@ -450,6 +461,9 @@ pprType, pprParendType :: Type -> SDoc pprType ty = ppr_type TopPrec ty pprParendType ty = ppr_type TyConPrec ty +pprTyLit :: TyLit -> SDoc +pprTyLit = ppr_tylit TopPrec + pprKind, pprParendKind :: Kind -> SDoc pprKind = pprType pprParendKind = pprParendType @@ -510,6 +524,9 @@ pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) instance Outputable Type where ppr ty = pprType ty +instance Outputable TyLit where + ppr = pprTyLit + instance Outputable name => OutputableBndr (IPName name) where pprBndr _ n = ppr n -- Simple for now pprInfixOcc n = ppr n @@ -521,6 +538,7 @@ instance Outputable name => OutputableBndr (IPName name) where ppr_type :: Prec -> Type -> SDoc ppr_type _ (TyVarTy tv) = ppr_tvar tv ppr_type p (TyConApp tc tys) = pprTcApp p ppr_type tc tys +ppr_type p (LiteralTy l) = ppr_tylit p l ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ pprType t1 <+> ppr_type TyConPrec t2 @@ -555,6 +573,9 @@ ppr_tvar :: TyVar -> SDoc ppr_tvar tv -- Note [Infix type variables] = parenSymOcc (getOccName tv) (ppr tv) +ppr_tylit :: Prec -> TyLit -> SDoc +ppr_tylit _ (NumberTyLit n) = integer n + ------------------- pprForAll :: [TyVar] -> SDoc pprForAll [] = empty diff --git a/compiler/utils/ListSetOps.lhs b/compiler/utils/ListSetOps.lhs index 2c6c6b0b6c..52415df353 100644 --- a/compiler/utils/ListSetOps.lhs +++ b/compiler/utils/ListSetOps.lhs @@ -5,12 +5,6 @@ \section[ListSetOps]{Set-like operations on lists} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module ListSetOps ( unionLists, minusList, insertList, @@ -24,9 +18,9 @@ module ListSetOps ( hasNoDups, runs, removeDups, findDupsEq, equivClasses, equivClassesByUniq, - -- Remove redudant elts - removeRedundant -- Used in the ghc/InteractiveUI, - -- although not in the compiler itself + -- Remove redudant elts + removeRedundant -- Used in the ghc/InteractiveUI, + -- although not in the compiler itself ) where #include "HsVersions.h" @@ -220,7 +214,7 @@ findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs where (eq_xs, neq_xs) = partition (eq x) xs removeRedundant :: (a -> a -> Bool) -- True <=> discard the *second* argument - -> [a] -> [a] + -> [a] -> [a] -- Remove any element y for which -- another element x is in the list -- and (x `subsumes` y) diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs index cebee633ee..751fdace50 100644 --- a/compiler/vectorise/Vectorise/Convert.hs +++ b/compiler/vectorise/Vectorise/Convert.hs @@ -78,6 +78,7 @@ identityConv (TyConApp tycon tys) = do { mapM_ identityConv tys ; identityConvTyCon tycon } +identityConv (LiteralTy _) = noV $ text "identityConv: not sure about literal types under vectorisation" identityConv (TyVarTy _) = noV $ text "identityConv: type variable changes under vectorisation" identityConv (AppTy _ _) = noV $ text "identityConv: type appl. changes under vectorisation" identityConv (FunTy _ _) = noV $ text "identityConv: function type changes under vectorisation" diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs index 7122cb7664..ff3803730e 100644 --- a/compiler/vectorise/Vectorise/Type/Classify.hs +++ b/compiler/vectorise/Vectorise/Type/Classify.hs @@ -106,4 +106,5 @@ tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys) tyConsOfType (AppTy a b) = tyConsOfType a `unionUniqSets` tyConsOfType b tyConsOfType (FunTy a b) = (tyConsOfType a `unionUniqSets` tyConsOfType b) `addOneToUniqSet` funTyCon +tyConsOfType (LiteralTy _) = emptyUniqSet tyConsOfType (ForAllTy _ ty) = tyConsOfType ty diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs index db724ad4bf..336b12618d 100644 --- a/compiler/vectorise/Vectorise/Type/Type.hs +++ b/compiler/vectorise/Vectorise/Type/Type.hs @@ -59,6 +59,7 @@ vectType ty | Just ty' <- coreView ty = vectType ty' vectType (TyVarTy tv) = return $ TyVarTy tv +vectType (LiteralTy l) = return $ LiteralTy l vectType (AppTy ty1 ty2) = AppTy <$> vectType ty1 <*> vectType ty2 vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys vectType (FunTy ty1 ty2) diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index 86bb73ed60..688cd02a80 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -9,7 +9,7 @@ SRC_CC_OPTS += -Wall $(WERROR) # Debian doesn't turn -Werror=unused-but-set-variable on by default, so # we turn it on explicitly for consistency with other users ifeq "$(GccLT46)" "NO" -SRC_CC_OPTS += -Werror=unused-but-set-variable +SRC_CC_OPTS += -Werror=unused-but-set-variable # gcc 4.6 gives 3 warning for giveCapabilityToTask not being inlined SRC_CC_OPTS += -Wno-error=inline endif diff --git a/rules/distdir-way-opts.mk b/rules/distdir-way-opts.mk index 7b516371e2..2e5f76462b 100644 --- a/rules/distdir-way-opts.mk +++ b/rules/distdir-way-opts.mk @@ -28,40 +28,40 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage # Variable Purpose Defined by # -------------- ------------------------------ -------------- # $1_PACKAGE Package name for this dir, $1/$2/ghc.mk -# if it is a package -# +# if it is a package +# # CONF_HC_OPTS GHC options from ./configure mk/config.mk.in -# +# # CONF_HC_OPTS_STAGE$4 GHC options from ./configure mk/config.mk.in -# specific to stage $4 -# +# specific to stage $4 +# # WAY_$3_HC_OPTS GHC options specific to way $3 mk/ways.mk -# +# # SRC_HC_OPTS source-tree-wide GHC options mk/config.mk.in # mk/build.mk # mk/validate.mk -# +# # EXTRA_HC_OPTS for supplying extra options on make EXTRA_HC_OPTS=... -# the command line -# +# the command line +# # $1_HC_OPTS GHC options specific to this $1/$2/package-data.mk # dir -# +# # $1_$2_HC_OPTS GHC options specific to this $1/$2/package-data.mk # dir and distdir -# +# # $1_$2_$3_HC_OPTS GHC options specific to this $1/$2/package-data.mk # dir, distdir and way -# +# # $1_$2_MORE_HC_OPTS GHC options for this dir/distdir ??? -# +# # $1_$2_EXTRA_HC_OPTS GHC options for this dir/distdir mk/build.mk -# +# # $1_$2_HC_PKGCONF -package-conf flag if necessary rules/package-config.mk -# +# # $1_$2_HS_SRC_DIRS dirs relative to $1 containing $1/$2/package-data.mk -# source files -# +# source files +# # $1_$2_CPP_OPTS CPP options $1/$2/package-data.mk # # <file>_HC_OPTS GHC options for this source $1/$2/ghc.mk |