Commit 4708d383 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge branch 'tc-untouchables'

parents 74d65116 815dcff1
......@@ -66,6 +66,7 @@ module BasicTypes(
StrictnessMark(..), isMarkedStrict,
DefMethSpec(..),
SwapFlag(..), flipSwap, unSwap,
CompilerPhase(..), PhaseNum,
Activation(..), isActive, isActiveIn,
......@@ -123,6 +124,31 @@ type RepArity = Int
type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
\end{code}
%************************************************************************
%* *
Swap flag
%* *
%************************************************************************
\begin{code}
data SwapFlag
= NotSwapped -- Args are: actual, expected
| IsSwapped -- Args are: expected, actual
instance Outputable SwapFlag where
ppr IsSwapped = ptext (sLit "Is-swapped")
ppr NotSwapped = ptext (sLit "Not-swapped")
flipSwap :: SwapFlag -> SwapFlag
flipSwap IsSwapped = NotSwapped
flipSwap NotSwapped = IsSwapped
unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
unSwap NotSwapped f a b = f a b
unSwap IsSwapped f a b = f b a
\end{code}
%************************************************************************
%* *
\subsection[FunctionOrData]{FunctionOrData}
......
......@@ -142,7 +142,7 @@ data IdDetails
-- instance C a => C [a]
-- has is_silent = 1, because the dfun
-- has type dfun :: (D a, C a) => C [a]
-- See the DFun Superclass Invariant in TcInstDcls
-- See Note [Silent superclass arguments] in TcInstDcls
--
-- Bool = True <=> the class has only one method, so may be
-- implemented with a newtype, so it might be bad
......
......@@ -45,7 +45,7 @@ module Name (
-- ** Creating 'Name's
mkSystemName, mkSystemNameAt,
mkInternalName, mkDerivedInternalName,
mkInternalName, mkClonedInternalName, mkDerivedInternalName,
mkSystemVarName, mkSysTvName,
mkFCallName,
mkExternalName, mkWiredInName,
......@@ -266,6 +266,11 @@ mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq
-- * for interface files we tidyCore first, which makes
-- the OccNames distinct when they need to be
mkClonedInternalName :: Unique -> Name -> Name
mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc })
= Name { n_uniq = getKeyFastInt uniq, n_sort = Internal
, n_occ = occ, n_loc = loc }
mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name
mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })
= Name { n_uniq = getKeyFastInt uniq, n_sort = Internal
......
......@@ -27,7 +27,8 @@ module VarEnv (
modifyVarEnv, modifyVarEnv_Directly,
isEmptyVarEnv, foldVarEnv,
elemVarEnvByKey, lookupVarEnv_Directly,
filterVarEnv_Directly, restrictVarEnv,
filterVarEnv_Directly, restrictVarEnv,
partitionVarEnv,
-- * The InScopeSet type
InScopeSet,
......@@ -384,6 +385,7 @@ extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a
lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)
restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a
delVarEnvList :: VarEnv a -> [Var] -> VarEnv a
delVarEnv :: VarEnv a -> Var -> VarEnv a
......@@ -430,6 +432,7 @@ isEmptyVarEnv = isNullUFM
foldVarEnv = foldUFM
lookupVarEnv_Directly = lookupUFM_Directly
filterVarEnv_Directly = filterUFM_Directly
partitionVarEnv = partitionUFM
restrictVarEnv env vs = filterVarEnv_Directly keep env
where
......
......@@ -838,6 +838,19 @@ lintCoercion the_co@(NthCo n co)
_ -> failWithL (hang (ptext (sLit "Bad getNth:"))
2 (ppr the_co $$ ppr s $$ ppr t)) }
lintCoercion the_co@(LRCo lr co)
= do { (_,s,t) <- lintCoercion co
; case (splitAppTy_maybe s, splitAppTy_maybe t) of
(Just s_pr, Just t_pr)
-> return (k, s_pick, t_pick)
where
s_pick = pickLR lr s_pr
t_pick = pickLR lr t_pr
k = typeKind s_pick
_ -> failWithL (hang (ptext (sLit "Bad LRCo:"))
2 (ppr the_co $$ ppr s $$ ppr t)) }
lintCoercion (InstCo co arg_ty)
= do { (k,s,t) <- lintCoercion co
; arg_kind <- lintType arg_ty
......
......@@ -74,6 +74,9 @@ data Ty
| UnsafeCoercion Ty Ty
| InstCoercion Ty Ty
| NthCoercion Int Ty
| LRCoercion LeftOrRight Ty
data LeftOrRight = CLeft | CRight
data Kind
= Klifted
......
......@@ -326,8 +326,13 @@ make_co dflags (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty dflags t1) (mak
make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co)
make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co)
make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co)
make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty)
make_lr :: LeftOrRight -> C.LeftOrRight
make_lr CLeft = C.CLeft
make_lr CRight = C.CRight
-- Used for both tycon app coercions and axiom instantiations.
make_conAppCo :: DynFlags -> C.Qual C.Tcon -> [Coercion] -> C.Ty
make_conAppCo dflags con cos =
......
......@@ -114,6 +114,10 @@ pty (UnsafeCoercion t1 t2) =
sep [text "%unsafe", paty t1, paty t2]
pty (NthCoercion n t) =
sep [text "%nth", int n, paty t]
pty (LRCoercion CLeft t) =
sep [text "%left", paty t]
pty (LRCoercion CRight t) =
sep [text "%right", paty t]
pty (InstCoercion t1 t2) =
sep [text "%inst", paty t1, paty t2]
pty t = pbty t
......
......@@ -470,6 +470,8 @@ data CoercionMap a
, km_sym :: CoercionMap a
, km_trans :: CoercionMap (CoercionMap a)
, km_nth :: IntMap.IntMap (CoercionMap a)
, km_left :: CoercionMap a
, km_right :: CoercionMap a
, km_inst :: CoercionMap (TypeMap a) }
wrapEmptyKM :: CoercionMap a
......@@ -477,7 +479,8 @@ wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyNameEnv
, km_app = emptyTM, km_forall = emptyTM
, km_var = emptyTM, km_axiom = emptyNameEnv
, km_unsafe = emptyTM, km_sym = emptyTM, km_trans = emptyTM
, km_nth = emptyTM, km_inst = emptyTM }
, km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM
, km_inst = emptyTM }
instance TrieMap CoercionMap where
type Key CoercionMap = Coercion
......@@ -493,7 +496,8 @@ mapC f (KM { km_refl = krefl, km_tc_app = ktc
, km_app = kapp, km_forall = kforall
, km_var = kvar, km_axiom = kax
, km_unsafe = kunsafe, km_sym = ksym, km_trans = ktrans
, km_nth = knth, km_inst = kinst })
, km_nth = knth, km_left = kml, km_right = kmr
, km_inst = kinst })
= KM { km_refl = mapTM f krefl
, km_tc_app = mapNameEnv (mapTM f) ktc
, km_app = mapTM (mapTM f) kapp
......@@ -504,6 +508,8 @@ mapC f (KM { km_refl = krefl, km_tc_app = ktc
, km_sym = mapTM f ksym
, km_trans = mapTM (mapTM f) ktrans
, km_nth = IntMap.map (mapTM f) knth
, km_left = mapTM f kml
, km_right = mapTM f kmr
, km_inst = mapTM (mapTM f) kinst }
lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a
......@@ -522,6 +528,8 @@ lkC env co m
go (CoVarCo v) = km_var >.> lkVar env v
go (SymCo c) = km_sym >.> lkC env c
go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c
go (LRCo CLeft c) = km_left >.> lkC env c
go (LRCo CRight c) = km_right >.> lkC env c
xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a
xtC env co f EmptyKM = xtC env co f wrapEmptyKM
......@@ -534,9 +542,11 @@ xtC env (UnsafeCo t1 t2) f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>>
xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f }
xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c
|>> xtBndr env v f }
xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f }
xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f }
xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f }
xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f }
xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f }
xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f }
xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f }
xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f }
fdC :: (a -> b -> b) -> CoercionMap a -> b -> b
fdC _ EmptyKM = \z -> z
......@@ -550,6 +560,8 @@ fdC k m = foldTM k (km_refl m)
. foldTM k (km_sym m)
. foldTM (foldTM k) (km_trans m)
. foldTM (foldTM k) (km_nth m)
. foldTM k (km_left m)
. foldTM k (km_right m)
. foldTM (foldTM k) (km_inst m)
\end{code}
......
......@@ -576,6 +576,7 @@ addTickHsExpr (HsWrap w e) =
(addTickHsExpr e) -- explicitly no tick on inside
addTickHsExpr e@(HsType _) = return e
addTickHsExpr HsHole = panic "addTickHsExpr.HsHole"
-- Others dhould never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
......
......@@ -440,8 +440,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| otherwise
= putSrcSpanDs loc $
do { let poly_name = idName poly_id
; spec_name <- newLocalName poly_name
do { uniq <- newUnique
; let poly_name = idName poly_id
spec_name = mkClonedInternalName uniq poly_name
; (bndrs, ds_lhs) <- liftM collectBinders
(dsHsWrapper spec_co (Var poly_id))
; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
......@@ -740,10 +741,6 @@ dsEvTerm (EvCast tm co)
-- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvKindCast v co)
= do { v' <- dsEvTerm v
; dsTcCoercion co $ (\_ -> v') }
dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms
; return (Var df `mkTyApps` tys `mkApps` tms') }
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
......@@ -833,6 +830,7 @@ ds_tc_coercion subst tc_co
go (TcSymCo co) = mkSymCo (go co)
go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2)
go (TcNthCo n co) = mkNthCo n (go co)
go (TcLRCo lr co) = mkLRCo lr (go co)
go (TcInstCo co ty) = mkInstCo (go co) ty
go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co
go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)
......
......@@ -216,6 +216,8 @@ dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty))
dsExpr (HsApp fun arg)
= mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
dsExpr HsHole = panic "dsExpr: HsHole"
\end{code}
Note [Desugaring vars]
......
......@@ -294,6 +294,7 @@ data HsExpr id
| HsWrap HsWrapper -- TRANSLATION
(HsExpr id)
| HsHole
deriving (Data, Typeable)
-- HsTupArg is used for tuple sections
......@@ -559,6 +560,8 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
ppr_expr (HsArrForm op _ args)
= hang (ptext (sLit "(|") <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
ppr_expr HsHole
= ptext $ sLit "_"
pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
......
......@@ -20,11 +20,12 @@ module BinIface (
#include "HsVersions.h"
import TcRnMonad
import TyCon (TyCon, tyConName, tupleTyConSort, tupleTyConArity, isTupleTyCon)
import TyCon
import DataCon (dataConName, dataConWorkId, dataConTyCon)
import PrelInfo (wiredInThings, basicKnownKeyNames)
import Id (idName, isDataConWorkId_maybe)
import CoreSyn (DFunArg(..))
import Coercion (LeftOrRight(..))
import TysWiredIn
import IfaceEnv
import HscTypes
......@@ -1037,6 +1038,15 @@ instance Binary IfaceTyCon where
put_ bh (IfaceTc ext) = put_ bh ext
get bh = liftM IfaceTc (get bh)
instance Binary LeftOrRight where
put_ bh CLeft = putByte bh 0
put_ bh CRight = putByte bh 1
get bh = do { h <- getByte bh
; case h of
0 -> return CLeft
_ -> return CRight }
instance Binary IfaceCoCon where
put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n }
put_ bh IfaceReflCo = putByte bh 1
......@@ -1045,6 +1055,7 @@ instance Binary IfaceCoCon where
put_ bh IfaceTransCo = putByte bh 4
put_ bh IfaceInstCo = putByte bh 5
put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d }
put_ bh (IfaceLRCo lr) = do { putByte bh 7; put_ bh lr }
get bh = do
h <- getByte bh
......@@ -1056,6 +1067,7 @@ instance Binary IfaceCoCon where
4 -> return IfaceTransCo
5 -> return IfaceInstCo
6 -> do { d <- get bh; return (IfaceNthCo d) }
7 -> do { lr <- get bh; return (IfaceLRCo lr) }
_ -> panic ("get IfaceCoCon " ++ show h)
-------------------------------------------------------------------------
......@@ -1392,6 +1404,18 @@ instance Binary IfaceDecl where
occ <- return $! mkOccNameFS tcName a1
return (IfaceAxiom occ a2 a3 a4)
instance Binary ty => Binary (SynTyConRhs ty) where
put_ bh (SynFamilyTyCon a b) = putByte bh 0 >> put_ bh a >> put_ bh b
put_ bh (SynonymTyCon ty) = putByte bh 1 >> put_ bh ty
get bh = do { h <- getByte bh
; case h of
0 -> do { a <- get bh
; b <- get bh
; return (SynFamilyTyCon a b) }
_ -> do { ty <- get bh
; return (SynonymTyCon ty) } }
instance Binary IfaceClsInst where
put_ bh (IfaceClsInst cls tys dfun flag orph) = do
put_ bh cls
......
......@@ -46,7 +46,7 @@ import Outputable
\begin{code}
------------------------------------------------------
buildSynTyCon :: Name -> [TyVar]
-> SynTyConRhs
-> SynTyConRhs Type
-> Kind -- ^ Kind of the RHS
-> TyConParent
-> TcRnIf m n TyCon
......
......@@ -35,6 +35,7 @@ module IfaceSyn (
#include "HsVersions.h"
import TyCon( SynTyConRhs(..) )
import IfaceType
import CoreSyn( DFunArg, dfunArgExprs )
import PprCore() -- Printing DFunArgs
......@@ -89,9 +90,7 @@ data IfaceDecl
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
ifSynRhs :: Maybe IfaceType -- Just rhs for an ordinary synonyn
-- Nothing for an type family declaration
}
ifSynRhs :: SynTyConRhs IfaceType }
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
ifName :: OccName, -- Name of the class TyCon
......@@ -487,12 +486,12 @@ pprIfaceDecl (IfaceForeign {ifName = tycon})
pprIfaceDecl (IfaceSyn {ifName = tycon,
ifTyVars = tyvars,
ifSynRhs = Just mono_ty})
ifSynRhs = SynonymTyCon mono_ty})
= hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty])
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifSynRhs = Nothing, ifSynKind = kind })
ifSynRhs = SynFamilyTyCon {}, ifSynKind = kind })
= hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr kind)
......@@ -797,9 +796,9 @@ freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc
freeNamesIfIdDetails _ = emptyNameSet
-- All other changes are handled via the version info on the tycon
freeNamesIfSynRhs :: Maybe IfaceType -> NameSet
freeNamesIfSynRhs (Just ty) = freeNamesIfType ty
freeNamesIfSynRhs Nothing = emptyNameSet
freeNamesIfSynRhs :: SynTyConRhs IfaceType -> NameSet
freeNamesIfSynRhs (SynonymTyCon ty) = freeNamesIfType ty
freeNamesIfSynRhs _ = emptyNameSet
freeNamesIfContext :: IfaceContext -> NameSet
freeNamesIfContext = fnList freeNamesIfType
......
......@@ -99,7 +99,7 @@ data IfaceCoCon
= IfaceCoAx IfExtName
| IfaceReflCo | IfaceUnsafeCo | IfaceSymCo
| IfaceTransCo | IfaceInstCo
| IfaceNthCo Int
| IfaceNthCo Int | IfaceLRCo LeftOrRight
\end{code}
%************************************************************************
......@@ -278,6 +278,7 @@ instance Outputable IfaceCoCon where
ppr IfaceTransCo = ptext (sLit "Trans")
ppr IfaceInstCo = ptext (sLit "Inst")
ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d
ppr (IfaceLRCo lr) = ppr lr
instance Outputable IfaceTyLit where
ppr = ppr_tylit
......@@ -376,6 +377,8 @@ coToIfaceType (TransCo co1 co2) = IfaceCoConApp IfaceTransCo
, coToIfaceType co2 ]
coToIfaceType (NthCo d co) = IfaceCoConApp (IfaceNthCo d)
[ coToIfaceType co ]
coToIfaceType (LRCo lr co) = IfaceCoConApp (IfaceLRCo lr)
[ coToIfaceType co ]
coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo
[ coToIfaceType co
, toIfaceType ty ]
......
......@@ -1459,11 +1459,11 @@ tyConToIfaceDecl env tycon
| Just clas <- tyConClass_maybe tycon
= classToIfaceDecl env clas
| isSynTyCon tycon
| Just syn_rhs <- synTyConRhs_maybe tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifSynRhs = syn_rhs,
ifSynKind = syn_ki }
ifSynRhs = to_ifsyn_rhs syn_rhs,
ifSynKind = tidyToIfaceType env1 (synTyConResKind tycon) }
| isAlgTyCon tycon
= IfaceData { ifName = getOccName tycon,
......@@ -1483,18 +1483,12 @@ tyConToIfaceDecl env tycon
where
(env1, tyvars) = tidyTyVarBndrs env (tyConTyVars tycon)
(syn_rhs, syn_ki)
= case synTyConRhs tycon of
SynFamilyTyCon ->
( Nothing
, tidyToIfaceType env1 (synTyConResKind tycon) )
SynonymTyCon ty ->
( Just (tidyToIfaceType env1 ty)
, tidyToIfaceType env1 (typeKind ty) )
to_ifsyn_rhs (SynFamilyTyCon a b) = SynFamilyTyCon a b
to_ifsyn_rhs (SynonymTyCon ty) = SynonymTyCon (tidyToIfaceType env1 ty)
ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls DataFamilyTyCon {} = IfDataFamTyCon
ifaceConDecls (DataFamilyTyCon {}) = IfDataFamTyCon
ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct
-- The last case happens when a TyCon has been trimmed during tidying
-- Furthermore, tyThingToIfaceDecl is also used
......
......@@ -474,9 +474,9 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
; return (ATyCon tycon) }
where
mk_doc n = ptext (sLit "Type syonym") <+> ppr n
tc_syn_rhs Nothing = return SynFamilyTyCon
tc_syn_rhs (Just ty) = do { rhs_ty <- tcIfaceType ty
; return (SynonymTyCon rhs_ty) }
tc_syn_rhs (SynFamilyTyCon a b) = return (SynFamilyTyCon a b)
tc_syn_rhs (SynonymTyCon ty) = do { rhs_ty <- tcIfaceType ty
; return (SynonymTyCon rhs_ty) }
tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
......@@ -962,6 +962,7 @@ tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t
tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2
tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t
tcIfaceCoApp (IfaceLRCo lr) [t] = LRCo lr <$> tcIfaceCo t
tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts)
tcIfaceCoVar :: FastString -> IfL CoVar
......
......@@ -510,6 +510,7 @@ data ExtensionFlag
| Opt_TraditionalRecordSyntax
| Opt_LambdaCase
| Opt_MultiWayIf
| Opt_TypeHoles
deriving (Eq, Enum, Show)
-- | Contains not only a collection of 'DynFlag's but also a plethora of
......@@ -2451,7 +2452,8 @@ xFlags = [
( "OverlappingInstances", Opt_OverlappingInstances, nop ),
( "UndecidableInstances", Opt_UndecidableInstances, nop ),
( "IncoherentInstances", Opt_IncoherentInstances, nop ),
( "PackageImports", Opt_PackageImports, nop )
( "PackageImports", Opt_PackageImports, nop ),
( "TypeHoles", Opt_TypeHoles, nop )
]
defaultFlags :: Platform -> [DynFlag]
......
......@@ -159,7 +159,7 @@ module GHC (
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
isFamilyTyCon, tyConClass_maybe,
synTyConDefn, synTyConType, synTyConResKind,
synTyConRhs_maybe, synTyConDefn_maybe, synTyConResKind,
-- ** Type variables
TyVar,
......
......@@ -165,13 +165,13 @@ pprTypeForUser print_foralls ty
pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc
pprTyCon pefas ss tyCon
| GHC.isSynTyCon tyCon
= if GHC.isFamilyTyCon tyCon
then pprTyConHdr pefas tyCon <+> dcolon <+>
pprTypeForUser pefas (GHC.synTyConResKind tyCon)
else
let rhs_type = GHC.synTyConType tyCon
in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type)
| Just syn_rhs <- GHC.synTyConRhs_maybe tyCon
= case syn_rhs of
SynFamilyTyCon {} -> pprTyConHdr pefas tyCon <+> dcolon <+>
pprTypeForUser pefas (GHC.synTyConResKind tyCon)
SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals)
2 (pprTypeForUser pefas rhs_ty)
| Just cls <- GHC.tyConClass_maybe tyCon
= pprClass pefas ss cls
| otherwise
......
......@@ -131,6 +131,7 @@ isStaticFlag f =
"fruntime-types",
"fno-pre-inlining",
"fno-opt-coercion",
"fno-flat-cache",
"fexcess-precision",
"fhardwire-lib-paths",
"fcpr-off",
......
......@@ -48,6 +48,7 @@ module StaticFlags (
opt_SimplExcessPrecision,
opt_NoOptCoercion,
opt_MaxWorkerArgs,
opt_NoFlatCache,
-- Unfolding control
opt_UF_CreationThreshold,
......@@ -243,6 +244,9 @@ opt_SimplExcessPrecision = lookUp (fsLit "-fexcess-precision")
opt_NoOptCoercion :: Bool
opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion")
opt_NoFlatCache :: Bool
opt_NoFlatCache = lookUp (fsLit "-fno-flat-cache")
-- Unfolding control
-- See Note [Discounts and thresholds] in CoreUnfold
......
......@@ -654,7 +654,13 @@ The type constructor Any of kind forall k. k -> k has these properties:
primitive type:
- has a fixed unique, anyTyConKey,
- lives in the global name cache
- built with TyCon.PrimTyCon
* It is a *closed* type family, with no instances. This means that
if ty :: '(k1, k2) we add a given coercion
g :: ty ~ (Fst ty, Snd ty)
If Any was a *data* type, then we'd get inconsistency becuase 'ty'
could be (Any '(k1,k2)) and then we'd have an equality with Any on
one side and '(,) on the other
* It is lifted, and hence represented by a pointer
......@@ -714,6 +720,17 @@ anyTyCon :: TyCon
anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep
where kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
{- Can't do this yet without messing up kind proxies
anyTyCon :: TyCon
anyTyCon = mkSynTyCon anyTyConName kind [kKiVar]
syn_rhs
NoParentTyCon
where
kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
syn_rhs = SynFamilyTyCon { synf_open = False, synf_injective = True }
-- NB Closed, injective
-}
anyTypeOfKind :: Kind -> Type
anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind]
\end{code}
......@@ -34,7 +34,7 @@ import HsSyn
import TcRnMonad
import TcEnv ( thRnBrack )
import RnEnv
import RnTypes
import RnTypes
import RnPat
import DynFlags
import BasicTypes ( FixityDirection(..) )
......@@ -299,6 +299,9 @@ rnExpr (ArithSeq _ seq)
rnExpr (PArrSeq _ seq)
= rnArithSeq seq `thenM` \ (new_seq, fvs) ->
return (PArrSeq noPostTcExpr new_seq, fvs)
rnExpr HsHole
= return (HsHole, emptyFVs)
\end{code}
These three are pattern syntax appearing in expressions.
......@@ -306,7 +309,11 @@ Since all the symbols are reservedops we can simply reject them.
We return a (bogus) EWildPat in each case.
\begin{code}
rnExpr e@EWildPat = patSynErr e
rnExpr e@EWildPat = do { holes <- xoptM Opt_TypeHoles
; if holes
then return (HsHole, emptyFVs)
else patSynErr e
}
rnExpr e@(EAsPat {}) = patSynErr e
rnExpr e@(EViewPat {}) = patSynErr e
rnExpr e@(ELazyPat {}) = patSynErr e
......@@ -331,6 +338,11 @@ rnExpr (HsArrApp arrow arg _ ho rtl)
return (HsArrApp arrow' arg' placeHolderType ho rtl,
fvArrow `plusFV` fvArg)
where
-- See Note [Escaping the arrow scope] in TcRnTypes
-- Before renaming 'arrow', use the environment of the enclosing
-- proc for the (-<) case.
-- Local bindings, inside the enclosing proc, are not in scope
-- inside 'arrow'. In the higher-order case (-<<), they are.
select_arrow_scope tc = case ho of
HsHigherOrderApp -> tc
HsFirstOrderApp -> escapeArrowScope tc
......
......@@ -477,7 +477,7 @@ mkStgAltType bndr alts = case repType (idType bndr) of
_is_poly_alt_tycon tc
= isFunTyCon tc
|| isPrimTyCon tc -- "Any" is lifted but primitive
|| isFamilyTyCon tc -- Type family; e.g. arising from strict
|| isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
-- function application where argument has a
-- type-family type
......
......@@ -26,7 +26,6 @@ import Name
import Module
import Outputable
import UniqFM
import VarSet
import FastString
import Util
import Maybes
......@@ -177,7 +176,9 @@ tcLookupFamInst tycon tys
| otherwise
= do { instEnv <- tcGetFamInstEnvs
; let mb_match = lookupFamInstEnv instEnv tycon tys
; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ ppr mb_match $$ ppr instEnv)
-- ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$
-- pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$
-- ppr mb_match $$ ppr instEnv)
; case mb_match of
[] -> return Nothing
((fam_inst, rep_tys):_)
......
......@@ -25,15 +25,12 @@ module Inst (
tcSyntaxName,
-- Simple functions over evidence variables
hasEqualities, unitImplication,
hasEqualities,
tyVarsOfWC, tyVarsOfBag,
tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication,
tyVarsOfCt, tyVarsOfCts, tyVarsOfCDict, tyVarsOfCDicts,
tyVarsOfCt, tyVarsOfCts,
tidyEvVar, tidyCt, tidyGivenLoc,
substEvVar, substImplication, substCt
tidyEvVar, tidyCt, tidySkolemInfo
) where
#include "HsVersions.h"
......@@ -86,7 +83,7 @@ emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
emitWanted origin pred
= do { loc <- getCtLoc origin
; ev <- newWantedEvVar pred
; emitFlat (mkNonCanonical (Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev }))
; emitFlat (mkNonCanonical loc (CtWanted { ctev_pred = pred, ctev_evar = ev }))
; return ev }
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
......@@ -366,14 +363,14 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do
syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
-> TcRn (TidyEnv, SDoc)
syntaxNameCtxt name orig ty tidy_env = do
inst_loc <- getCtLoc orig
let
msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
ptext (sLit "(needed by a syntactic construct)"),
nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
nest 2 (pprArisingAt inst_loc)]
return (tidy_env, msg)
syntaxNameCtxt name orig ty tidy_env
= do { inst_loc <- getCtLoc orig
; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name)
<+> ptext (sLit "(needed by a syntactic construct)")
, nest 2 (ptext (sLit "has the required type:")
<+> ppr (tidyType tidy_env ty))
, nest 2 (pprArisingAt inst_loc) ]
; return (tidy_env, msg) }
\end{code}