Commit a6b0ab26 authored by ian@well-typed.com's avatar ian@well-typed.com

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

parents 1b3f2747 65e6470c
......@@ -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}
......
......@@ -37,7 +37,7 @@ module DataCon (
dataConRepStrictness,
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon, dataConCannotMatch,
-- * Splitting product types
......@@ -838,8 +838,8 @@ dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++
\end{code}
\begin{code}
isTupleCon :: DataCon -> Bool
isTupleCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
isTupleDataCon :: DataCon -> Bool
isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
isUnboxedTupleCon :: DataCon -> Bool
isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc
......
\begin{code}
module DataCon where
import Name( Name )
import {-# SOURCE #-} TyCon( TyCon )
data DataCon
dataConName :: DataCon -> Name
dataConTyCon :: DataCon -> TyCon
isVanillaDataCon :: DataCon -> Bool
instance Eq DataCon
instance Ord DataCon
......
......@@ -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
......
......@@ -751,9 +751,14 @@ mkPrimOpId prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info
info = noCafIdInfo
`setSpecInfo` mkSpecInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setSpecInfo` mkSpecInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setStrictnessInfo` Just strict_sig
`setInlinePragInfo` neverInlinePragma
-- We give PrimOps a NOINLINE pragma so that we don't
-- get silly warnings from Desugar.dsRule (the inline_shadows_rule
-- test) about a RULE conflicting with a possible inlining
-- cf Trac #7287
-- For each ccall we manufacture a separate CCallOpId, giving it
-- a fresh unique, a type that is correct for this particular ccall,
......
......@@ -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}
......
......@@ -529,7 +529,7 @@ similar) at the same time that we create the constructors.
You can tell tuple constructors using
\begin{verbatim}
Id.isTupleCon
Id.isTupleDataCon
\end{verbatim}
You can see if one constructor is infix with this clearer code :-))))))))))
\begin{verbatim}
......
......@@ -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)
......@@ -584,19 +585,19 @@ addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') }
addTickTupArg (Missing ty) = return (Missing ty)
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id -> TM (MatchGroup Id)
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
addTickMatchGroup is_lam (MatchGroup matches ty) = do
let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
return $ MatchGroup matches' ty
addTickMatch :: Bool -> Bool -> Match Id -> TM (Match Id)
addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ Match pats opSig gRHSs'
addTickGRHSs :: Bool -> Bool -> GRHSs Id -> TM (GRHSs Id)
addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
......@@ -605,7 +606,7 @@ addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
where
binders = collectLocalBinders local_binds
addTickGRHS :: Bool -> Bool -> GRHS Id -> TM (GRHS Id)
addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))
addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
(stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
(addTickGRHSBody isOneOfMany isLambda expr)
......@@ -623,20 +624,20 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
_otherwise ->
addTickLHsExprRHS expr
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]
addTickLStmts isGuard stmts = do
(stmts, _) <- addTickLStmts' isGuard stmts (return ())
return stmts
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
-> TM ([LStmt Id], a)
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a
-> TM ([ExprLStmt Id], a)
addTickLStmts' isGuard lstmts res
= bindLocals (collectLStmtsBinders lstmts) $
do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
; a <- res
; return (lstmts', a) }
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))
addTickStmt _isGuard (LastStmt e ret) = do
liftM2 LastStmt
(addTickLHsExpr e)
......@@ -647,8 +648,8 @@ addTickStmt _isGuard (BindStmt pat e bind fail) = do
(addTickLHsExprRHS e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
liftM4 ExprStmt
addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
liftM4 BodyStmt
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
......@@ -750,63 +751,65 @@ addTickLHsCmd (L pos c0) = do
return $ L pos c1
addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
addTickHsCmd (HsLam matchgroup) =
liftM HsLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsApp c e) =
liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e)
addTickHsCmd (HsCmdLam matchgroup) =
liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsCmdApp c e) =
liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
{-
addTickHsCmd (OpApp e1 c2 fix c3) =
liftM4 OpApp
(addTickLHsExpr e1)
(addTickLHsCmd c2)
(return fix)
(addTickLHsCmd c3)
addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
addTickHsCmd (HsCase e mgs) =
liftM2 HsCase
-}
addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
addTickHsCmd (HsCmdCase e mgs) =
liftM2 HsCmdCase
(addTickLHsExpr e)
(addTickCmdMatchGroup mgs)
addTickHsCmd (HsIf cnd e1 c2 c3) =
liftM3 (HsIf cnd)
addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
liftM3 (HsCmdIf cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
addTickHsCmd (HsLet binds c) =
addTickHsCmd (HsCmdLet binds c) =
bindLocals (collectLocalBinders binds) $
liftM2 HsLet
liftM2 HsCmdLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
addTickHsCmd (HsDo cxt stmts srcloc)
addTickHsCmd (HsCmdDo stmts srcloc)
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
; return (HsDo cxt stmts' srcloc) }
; return (HsCmdDo stmts' srcloc) }
addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp
addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsCmdArrApp
(addTickLHsExpr e1)
(addTickLHsExpr e2)
(return ty1)
(return arr_ty)
(return lr)
addTickHsCmd (HsArrForm e fix cmdtop) =
liftM3 HsArrForm
addTickHsCmd (HsCmdArrForm e fix cmdtop) =
liftM3 HsCmdArrForm
(addTickLHsExpr e)
(return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
-- Others should never happen in a command context.
addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
addTickCmdMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
addTickCmdMatchGroup (MatchGroup matches ty) = do
matches' <- mapM (liftL addTickCmdMatch) matches
return $ MatchGroup matches' ty
addTickCmdMatch :: Match Id -> TM (Match Id)
addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
addTickCmdMatch (Match pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickCmdGRHSs gRHSs
return $ Match pats opSig gRHSs'
addTickCmdGRHSs :: GRHSs Id -> TM (GRHSs Id)
addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
addTickCmdGRHSs (GRHSs guarded local_binds) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
......@@ -815,7 +818,7 @@ addTickCmdGRHSs (GRHSs guarded local_binds) = do
where
binders = collectLocalBinders local_binds
addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))
-- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff
addTickCmdGRHS (GRHS stmts cmd)
......@@ -823,12 +826,12 @@ addTickCmdGRHS (GRHS stmts cmd)
stmts (addTickLHsCmd cmd)
; return $ GRHS stmts' expr' }
addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]
addTickLCmdStmts stmts = do
(stmts, _) <- addTickLCmdStmts' stmts (return ())
return stmts
addTickLCmdStmts' :: [LStmt Id] -> TM a -> TM ([LStmt Id], a)
addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a)
addTickLCmdStmts' lstmts res
= bindLocals binders $ do
lstmts' <- mapM (liftL addTickCmdStmt) lstmts
......@@ -837,7 +840,7 @@ addTickLCmdStmts' lstmts res
where
binders = collectLStmtsBinders lstmts
addTickCmdStmt :: Stmt Id -> TM (Stmt Id)
addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))
addTickCmdStmt (BindStmt pat c bind fail) = do
liftM4 BindStmt
(addTickLPat pat)
......@@ -848,8 +851,8 @@ addTickCmdStmt (LastStmt c ret) = do
liftM2 LastStmt
(addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickCmdStmt (ExprStmt c bind' guard' ty) = do
liftM4 ExprStmt
addTickCmdStmt (BodyStmt c bind' guard' ty) = do
liftM4 BodyStmt
(addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
......@@ -1142,7 +1145,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
\begin{code}
matchesOneOfMany :: [LMatch Id] -> Bool
matchesOneOfMany :: [LMatch Id body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where
matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
......
This diff is collapsed.
......@@ -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]
......@@ -322,12 +324,12 @@ dsExpr (HsLet binds body) = do
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
dsExpr (HsDo DoExpr stmts _) = dsDo stmts
dsExpr (HsDo GhciStmt stmts _) = dsDo stmts
dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
dsExpr (HsDo DoExpr stmts _) = dsDo stmts
dsExpr (HsDo GhciStmtCtxt stmts _) = dsDo stmts
dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
......@@ -717,7 +719,7 @@ handled in DsListComp). Basically does the translation given in the
Haskell 98 report:
\begin{code}
dsDo :: [LStmt Id] -> DsM CoreExpr
dsDo :: [ExprLStmt Id] -> DsM CoreExpr
dsDo stmts
= goL stmts
where
......@@ -728,7 +730,7 @@ dsDo stmts
= ASSERT( null stmts ) dsLExpr body
-- The 'return' op isn't used for 'do' expressions
go _ (ExprStmt rhs then_expr _ _) stmts
go _ (BodyStmt rhs then_expr _ _) stmts
= do { rhs2 <- dsLExpr rhs
; warnDiscardedDoBindings rhs (exprType rhs2)
; then_expr2 <- dsExpr then_expr
......
......@@ -40,7 +40,7 @@ producing an expression with a runtime error in the corner if
necessary. The type argument gives the type of the @ei@.
\begin{code}
dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr
dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr
dsGuarded grhss rhs_ty = do
match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty
......@@ -52,7 +52,7 @@ In contrast, @dsGRHSs@ produces a @MatchResult@.
\begin{code}
dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from
-> GRHSs Id -- Guarded RHSs
-> GRHSs Id (LHsExpr Id) -- Guarded RHSs
-> Type -- Type of RHS
-> DsM MatchResult
dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do
......@@ -66,7 +66,7 @@ dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do
--
return match_result2
dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id -> DsM MatchResult
dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult
dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
\end{code}
......@@ -79,31 +79,31 @@ dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
%************************************************************************
\begin{code}
matchGuards :: [Stmt Id] -- Guard
-> HsStmtContext Name -- Context
-> LHsExpr Id -- RHS
-> Type -- Type of RHS of guard
matchGuards :: [GuardStmt Id] -- Guard
-> HsStmtContext Name -- Context
-> LHsExpr Id -- RHS
-> Type -- Type of RHS of guard
-> DsM MatchResult
-- See comments with HsExpr.Stmt re what an ExprStmt means
-- See comments with HsExpr.Stmt re what a BodyStmt means
-- Here we must be in a guard context (not do-expression, nor list-comp)
matchGuards [] _ rhs _
= do { core_rhs <- dsLExpr rhs
; return (cantFailMatchResult core_rhs) }
-- ExprStmts must be guards
-- BodyStmts must be guards
-- Turn an "otherwise" guard is a no-op. This ensures that
-- you don't get a "non-exhaustive eqns" message when the guards
-- finish in "otherwise".
-- NB: The success of this clause depends on the typechecker not
-- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
-- If it does, you'll get bogus overlap warnings
matchGuards (ExprStmt e _ _ _ : stmts) ctx rhs rhs_ty
matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty
| Just addTicks <- isTrueLHsExpr e = do
match_result <- matchGuards stmts ctx rhs rhs_ty
return (adjustMatchResultDs addTicks match_result)
matchGuards (ExprStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
match_result <- matchGuards stmts ctx rhs rhs_ty
pred_expr <- dsLExpr expr
return (mkGuardedMatchResult pred_expr match_result)
......
......@@ -43,7 +43,7 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject).
There will be at least one ``qualifier'' in the input.
\begin{code}
dsListComp :: [LStmt Id]
dsListComp :: [ExprLStmt Id]
-> Type -- Type of entire list
-> DsM CoreExpr
dsListComp lquals res_ty = do
......@@ -89,7 +89,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _)
-- This function factors out commonality between the desugaring strategies for GroupStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
dsTransStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id)
dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
, trS_by = by, trS_using = using }) = do
let (from_bndrs, to_bndrs) = unzip binderMap
......@@ -204,7 +204,7 @@ with the Unboxed variety.
\begin{code}
deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr
deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr
deListComp [] _ = panic "deListComp"
......@@ -215,7 +215,7 @@ deListComp (LastStmt body _ : quals) list
; return (mkConsExpr (exprType core_body) core_body list) }
-- Non-last: must be a guard
deListComp (ExprStmt guard _ _ _ : quals) list = do -- rule B above
deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above
core_guard <- dsLExpr guard
core_rest <- deListComp quals list
return (mkIfThenElse core_guard core_rest list)
......@@ -256,7 +256,7 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
\begin{code}
deBindComp :: OutPat Id
-> CoreExpr
-> [Stmt Id]
-> [ExprStmt Id]
-> CoreExpr
-> DsM (Expr Id)
deBindComp pat core_list1 quals core_list2 = do
......@@ -309,8 +309,8 @@ TE[ e | p <- l , q ] c n = let
\end{verbatim}
\begin{code}
dfListComp :: Id -> Id -- 'c' and 'n'
-> [Stmt Id] -- the rest of the qual's
dfListComp :: Id -> Id -- 'c' and 'n'
-> [ExprStmt Id] -- the rest of the qual's
-> DsM CoreExpr
dfListComp _ _ [] = panic "dfListComp"
......@@ -321,7 +321,7 @@ dfListComp c_id n_id (LastStmt body _ : quals)
; return (mkApps (Var c_id) [core_body, Var n_id]) }
-- Non-last: must be a guard
dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) = do
dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do
core_guard <- dsLExpr guard
core_rest <- dfListComp c_id n_id quals
return (mkIfThenElse core_guard core_rest (Var n_id))
......@@ -347,8 +347,8 @@ dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat Id, CoreExpr)
-> [Stmt Id] -- the rest of the qual's
-> (LPat Id, CoreExpr)
-> [ExprStmt Id] -- the rest of the qual's
-> DsM CoreExpr
dfBindComp c_id n_id (pat, core_list1) quals = do
-- find the required type
......@@ -469,7 +469,7 @@ mkUnzipBind _ elt_tys
--
-- [:e | qss:] = <<[:e | qss:]>> () [:():]
--
dsPArrComp :: [Stmt Id]
dsPArrComp :: [ExprStmt Id]
-> DsM CoreExpr
-- Special case for parallel comprehension
......@@ -505,7 +505,7 @@ dsPArrComp qs = do -- no ParStmt in `qs'
-- the work horse
--