summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2014-09-26 12:58:41 +0100
committerSimon Peyton Jones <simonpj@microsoft.com>2014-09-26 13:55:11 +0100
commit0ef1cc67dc472493b7dee1a28dedbfe938536b8f (patch)
tree59aa09b676707607792fd8a0430ba23afc608839 /compiler/deSugar
parentac157de3cd959a18a71fa056403675e2c0563497 (diff)
downloadhaskell-0ef1cc67dc472493b7dee1a28dedbfe938536b8f.tar.gz
De-tabify and remove trailing whitespace
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/DsArrows.lhs440
-rw-r--r--compiler/deSugar/DsBinds.lhs348
-rw-r--r--compiler/deSugar/DsUtils.lhs220
-rw-r--r--compiler/deSugar/MatchCon.lhs124
4 files changed, 554 insertions, 578 deletions
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 35a2477fd5..8f8e2d9f16 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -7,12 +7,6 @@ Desugaring arrow commands
\begin{code}
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
module DsArrows ( dsProcExpr ) where
@@ -22,7 +16,7 @@ import Match
import DsUtils
import DsMonad
-import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )
+import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )
import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
@@ -58,7 +52,7 @@ import Data.List
\begin{code}
data DsCmdEnv = DsCmdEnv {
- arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
+ arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
}
mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv)
@@ -78,7 +72,7 @@ mkCmdEnv tc_meths
= do { rhs <- dsExpr expr
; id <- newSysLocalDs (exprType rhs)
; return (NonRec id rhs, (std_name, id)) }
-
+
find_meth prs std_name
= assocDefault (mk_panic std_name) prs std_name
mk_panic std_name = pprPanic "mkCmdEnv" (ptext (sLit "Not found:") <+> ppr std_name)
@@ -89,7 +83,7 @@ do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
-- (>>>) :: forall b c d. a b c -> a c d -> a b d
do_compose :: DsCmdEnv -> Type -> Type -> Type ->
- CoreExpr -> CoreExpr -> CoreExpr
+ CoreExpr -> CoreExpr -> CoreExpr
do_compose ids b_ty c_ty d_ty f g
= mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
@@ -105,7 +99,7 @@ do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
-- note the swapping of d and c
do_choice :: DsCmdEnv -> Type -> Type -> Type ->
- CoreExpr -> CoreExpr -> CoreExpr
+ CoreExpr -> CoreExpr -> CoreExpr
do_choice ids b_ty c_ty d_ty f g
= mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
@@ -118,7 +112,7 @@ do_loop ids b_ty c_ty d_ty f
-- premap :: forall b c d. (b -> c) -> a c d -> a b d
-- premap f g = arr f >>> g
do_premap :: DsCmdEnv -> Type -> Type -> Type ->
- CoreExpr -> CoreExpr -> CoreExpr
+ CoreExpr -> CoreExpr -> CoreExpr
do_premap ids b_ty c_ty d_ty f g
= do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
@@ -150,7 +144,7 @@ because the list of variables is typically not yet defined.
\begin{code}
-- coreCaseTuple [u1..] v [x1..xn] body
--- = case v of v { (x1, .., xn) -> body }
+-- = case v of v { (x1, .., xn) -> body }
-- But the matching may be nested if the tuple is very big
coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
@@ -178,7 +172,7 @@ The input is divided into a local environment, which is a flat tuple
(unless it's too big), and a stack, which is a right-nested pair.
In general, the input has the form
- ((x1,...,xn), (s1,...(sk,())...))
+ ((x1,...,xn), (s1,...(sk,())...))
where xi are the environment values, and si the ones on the stack,
with s1 being the "top", the first one to be matched with a lambda.
@@ -196,28 +190,28 @@ splitTypeAt n ty
_ -> pprPanic "splitTypeAt" (ppr ty)
----------------------------------------------
--- buildEnvStack
+-- buildEnvStack
--
--- ((x1,...,xn),stk)
+-- ((x1,...,xn),stk)
buildEnvStack :: [Id] -> Id -> CoreExpr
buildEnvStack env_ids stack_id
= mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)
----------------------------------------------
--- matchEnvStack
+-- matchEnvStack
--
--- \ ((x1,...,xn),stk) -> body
--- =>
--- \ pair ->
--- case pair of (tup,stk) ->
--- case tup of (x1,...,xn) ->
--- body
-
-matchEnvStack :: [Id] -- x1..xn
- -> Id -- stk
- -> CoreExpr -- e
- -> DsM CoreExpr
+-- \ ((x1,...,xn),stk) -> body
+-- =>
+-- \ pair ->
+-- case pair of (tup,stk) ->
+-- case tup of (x1,...,xn) ->
+-- body
+
+matchEnvStack :: [Id] -- x1..xn
+ -> Id -- stk
+ -> CoreExpr -- e
+ -> DsM CoreExpr
matchEnvStack env_ids stack_id body = do
uniqs <- newUniqueSupply
tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
@@ -226,30 +220,30 @@ matchEnvStack env_ids stack_id body = do
return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
----------------------------------------------
--- matchEnv
+-- matchEnv
--
--- \ (x1,...,xn) -> body
--- =>
--- \ tup ->
--- case tup of (x1,...,xn) ->
--- body
-
-matchEnv :: [Id] -- x1..xn
- -> CoreExpr -- e
- -> DsM CoreExpr
+-- \ (x1,...,xn) -> body
+-- =>
+-- \ tup ->
+-- case tup of (x1,...,xn) ->
+-- body
+
+matchEnv :: [Id] -- x1..xn
+ -> CoreExpr -- e
+ -> DsM CoreExpr
matchEnv env_ids body = do
uniqs <- newUniqueSupply
tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))
----------------------------------------------
--- matchVarStack
+-- matchVarStack
--
--- case (x1, ...(xn, s)...) -> e
--- =>
--- case z0 of (x1,z1) ->
--- case zn-1 of (xn,s) ->
--- e
+-- case (x1, ...(xn, s)...) -> e
+-- =>
+-- case z0 of (x1,z1) ->
+-- case zn-1 of (xn,s) ->
+-- e
matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
matchVarStack [] stack_id body = return (stack_id, body)
matchVarStack (param_id:param_ids) stack_id body = do
@@ -268,16 +262,16 @@ Translation of arrow abstraction
\begin{code}
--- D; xs |-a c : () --> t' ---> c'
+-- D; xs |-a c : () --> t' ---> c'
-- --------------------------
--- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c'
+-- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c'
--
--- where (xs) is the tuple of variables bound by p
+-- where (xs) is the tuple of variables bound by p
dsProcExpr
- :: LPat Id
- -> LHsCmdTop Id
- -> DsM CoreExpr
+ :: LPat Id
+ -> LHsCmdTop Id
+ -> DsM CoreExpr
dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
(meth_binds, meth_ids) <- mkCmdEnv ids
let locals = mkVarSet (collectPatBinders pat)
@@ -297,11 +291,11 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
Translation of a command judgement of the form
- D; xs |-a c : stk --> t
+ D; xs |-a c : stk --> t
to an expression e such that
- D |- e :: a (xs, stk) t
+ D |- e :: a (xs, stk) t
\begin{code}
dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id]
@@ -309,23 +303,23 @@ dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id]
dsLCmd ids local_vars stk_ty res_ty cmd env_ids
= dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids
-dsCmd :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this command
- -> Type -- type of the stack (right-nested tuple)
- -> Type -- return type of the command
- -> HsCmd Id -- command to desugar
- -> [Id] -- list of vars in the input to this command
- -- This is typically fed back,
- -- so don't pull on it too early
- -> DsM (CoreExpr, -- desugared expression
- IdSet) -- subset of local vars that occur free
+dsCmd :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this command
+ -> Type -- type of the stack (right-nested tuple)
+ -> Type -- return type of the command
+ -> HsCmd Id -- command to desugar
+ -> [Id] -- list of vars in the input to this command
+ -- This is typically fed back,
+ -- so don't pull on it too early
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- subset of local vars that occur free
-- D |- fun :: a t1 t2
-- D, xs |- arg :: t1
-- -----------------------------
-- D; xs |-a fun -< arg : stk --> t2
--
--- ---> premap (\ ((xs), _stk) -> arg) fun
+-- ---> premap (\ ((xs), _stk) -> arg) fun
dsCmd ids local_vars stack_ty res_ty
(HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
@@ -350,7 +344,7 @@ dsCmd ids local_vars stack_ty res_ty
-- ------------------------------
-- D; xs |-a fun -<< arg : stk --> t2
--
--- ---> premap (\ ((xs), _stk) -> (fun, arg)) app
+-- ---> premap (\ ((xs), _stk) -> (fun, arg)) app
dsCmd ids local_vars stack_ty res_ty
(HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
@@ -358,7 +352,7 @@ dsCmd ids local_vars stack_ty res_ty
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
-
+
core_arrow <- dsLExpr arrow
core_arg <- dsLExpr arg
stack_id <- newSysLocalDs stack_ty
@@ -379,7 +373,7 @@ dsCmd ids local_vars stack_ty res_ty
-- ------------------------
-- D; xs |-a cmd exp : stk --> t'
--
--- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
+-- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
core_arg <- dsLExpr arg
@@ -392,9 +386,9 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
arg_id <- newSysLocalDs arg_ty
-- push the argument expression onto the stack
let
- stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
+ stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
core_body = bindNonRec arg_id core_arg
- (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
+ (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
-- match the environment and stack against the input
core_map <- matchEnvStack env_ids stack_id core_body
@@ -411,7 +405,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
-- -----------------------------------------------
-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'
--
--- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
+-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
dsCmd ids local_vars stack_ty res_ty
(HsCmdLam (MG { mg_alts = [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] }))
@@ -419,7 +413,7 @@ dsCmd ids local_vars stack_ty res_ty
let
pat_vars = mkVarSet (collectPatsBinders pats)
local_vars' = pat_vars `unionVarSet` local_vars
- (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
+ (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
(core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body
param_ids <- mapM newSysLocalDs pat_tys
stack_id' <- newSysLocalDs stack_ty'
@@ -432,7 +426,7 @@ dsCmd ids local_vars stack_ty res_ty
core_expr = buildEnvStack env_ids' stack_id'
in_ty = envStackType env_ids stack_ty
in_ty' = envStackType env_ids' stack_ty'
-
+
fail_expr <- mkFailExpr LambdaExpr in_ty'
-- match the patterns against the parameters
match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr
@@ -452,9 +446,9 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
-- ----------------------------------------
-- D; xs |-a if e then c1 else c2 : stk --> t
--
--- ---> premap (\ ((xs),stk) ->
--- if e then Left ((xs1),stk) else Right ((xs2),stk))
--- (c1 ||| c2)
+-- ---> premap (\ ((xs),stk) ->
+-- if e then Left ((xs1),stk) else Right ((xs2),stk))
+-- (c1 ||| c2)
dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
env_ids = do
@@ -474,11 +468,11 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
else_ty = envStackType else_ids stack_ty
sum_ty = mkTyConApp either_con [then_ty, else_ty]
fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars
-
+
core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_id)
core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id)
- core_if <- case mb_fun of
+ core_if <- case mb_fun of
Just fun -> do { core_fun <- dsExpr fun
; matchEnvStack env_ids stack_id $
mkCoreApps core_fun [core_cond, core_left, core_right] }
@@ -494,15 +488,15 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
Case commands are treated in much the same way as if commands
(see above) except that there are more alternatives. For example
- case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
+ case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
is translated to
- premap (\ ((xs)*ts) -> case e of
- p1 -> (Left (Left (xs1)*ts))
- p2 -> Left ((Right (xs2)*ts))
- p3 -> Right ((xs3)*ts))
- ((c1 ||| c2) ||| c3)
+ premap (\ ((xs)*ts) -> case e of
+ p1 -> (Left (Left (xs1)*ts))
+ p2 -> Left ((Right (xs2)*ts))
+ p3 -> Right ((xs3)*ts))
+ ((c1 ||| c2) ||| c3)
The idea is to extract the commands from the case, build a balanced tree
of choices, and replace the commands with expressions that build tagged
@@ -517,7 +511,7 @@ case bodies, containing the following fields:
bodies with |||.
\begin{code}
-dsCmd ids local_vars stack_ty res_ty
+dsCmd ids local_vars stack_ty res_ty
(HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin }))
env_ids = do
stack_id <- newSysLocalDs stack_ty
@@ -533,7 +527,7 @@ dsCmd ids local_vars stack_ty res_ty
return ([mkHsEnvStackExpr leaf_ids stack_id],
envStackType leaf_ids stack_ty,
core_leaf)
-
+
branches <- mapM make_branch leaves
either_con <- dsLookupTyCon eitherTyConName
left_con <- dsLookupDataCon leftDataConName
@@ -574,13 +568,13 @@ dsCmd ids local_vars stack_ty res_ty
-- ----------------------------------
-- D; xs |-a let binds in cmd : stk --> t
--
--- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
+-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do
let
defined_vars = mkVarSet (collectLocalBinders binds)
local_vars' = defined_vars `unionVarSet` local_vars
-
+
(core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body
stack_id <- newSysLocalDs stack_ty
-- build a new environment, plus the stack, using the let bindings
@@ -599,24 +593,24 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do
-- ----------------------------------
-- D; xs |-a do { ss } : () --> t
--
--- ---> premap (\ (env,stk) -> env) c
+-- ---> premap (\ (env,stk) -> env) c
dsCmd ids local_vars stack_ty res_ty (HsCmdDo stmts _) env_ids = do
(core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
let env_ty = mkBigCoreVarTupTy env_ids
core_fst <- mkFstExpr env_ty stack_ty
return (do_premap ids
- (mkCorePairTy env_ty stack_ty)
- env_ty
- res_ty
- core_fst
- core_stmts,
- env_ids')
+ (mkCorePairTy env_ty stack_ty)
+ env_ty
+ res_ty
+ core_fst
+ core_stmts,
+ env_ids')
-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
-- D; xs |-a ci :: stki --> ti
-- -----------------------------------
--- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
+-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do
let env_ty = mkBigCoreVarTupTy env_ids
@@ -632,16 +626,16 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do
dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
--- D; ys |-a c : stk --> t (ys <= xs)
+-- D; ys |-a c : stk --> t (ys <= xs)
-- ---------------------
--- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c
+-- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c
dsTrimCmdArg
- :: IdSet -- set of local vars available to this command
- -> [Id] -- list of vars in the input to this command
- -> LHsCmdTop Id -- command argument to desugar
- -> DsM (CoreExpr, -- desugared expression
- IdSet) -- subset of local vars that occur free
+ :: IdSet -- set of local vars available to this command
+ -> [Id] -- list of vars in the input to this command
+ -> LHsCmdTop Id -- command argument to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- subset of local vars that occur free
dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
(meth_binds, meth_ids) <- mkCmdEnv ids
(core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
@@ -658,14 +652,14 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
dsfixCmd
- :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this command
- -> Type -- type of the stack (right-nested tuple)
- -> Type -- return type of the command
- -> LHsCmd Id -- command to desugar
- -> DsM (CoreExpr, -- desugared expression
- IdSet, -- subset of local vars that occur free
- [Id]) -- the same local vars as a list, fed back
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this command
+ -> Type -- type of the stack (right-nested tuple)
+ -> Type -- return type of the command
+ -> LHsCmd Id -- command to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet, -- subset of local vars that occur free
+ [Id]) -- the same local vars as a list, fed back
dsfixCmd ids local_vars stk_ty cmd_ty cmd
= trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd)
@@ -673,12 +667,12 @@ dsfixCmd ids local_vars stk_ty cmd_ty cmd
-- for use as the input tuple of the generated arrow.
trimInput
- :: ([Id] -> DsM (CoreExpr, IdSet))
- -> DsM (CoreExpr, -- desugared expression
- IdSet, -- subset of local vars that occur free
- [Id]) -- same local vars as a list, fed back to
- -- the inner function to form the tuple of
- -- inputs to the arrow.
+ :: ([Id] -> DsM (CoreExpr, IdSet))
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet, -- subset of local vars that occur free
+ [Id]) -- same local vars as a list, fed back to
+ -- the inner function to form the tuple of
+ -- inputs to the arrow.
trimInput build_arrow
= fixDs (\ ~(_,_,env_ids) -> do
(core_cmd, free_vars) <- build_arrow env_ids
@@ -688,19 +682,19 @@ trimInput build_arrow
Translation of command judgements of the form
- D |-a do { ss } : t
+ D |-a do { ss } : t
\begin{code}
-dsCmdDo :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this statement
- -> Type -- return type of the statement
- -> [CmdLStmt Id] -- statements to desugar
- -> [Id] -- list of vars in the input to this statement
- -- This is typically fed back,
- -- so don't pull on it too early
- -> DsM (CoreExpr, -- desugared expression
- IdSet) -- subset of local vars that occur free
+dsCmdDo :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> Type -- return type of the statement
+ -> [CmdLStmt Id] -- statements to desugar
+ -> [Id] -- list of vars in the input to this statement
+ -- This is typically fed back,
+ -- so don't pull on it too early
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- subset of local vars that occur free
dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
@@ -708,7 +702,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
-- --------------------------
-- D; xs |-a do { c } : t
--
--- ---> premap (\ (xs) -> ((xs), ())) c
+-- ---> premap (\ (xs) -> ((xs), ())) c
dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids = do
(core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
@@ -717,11 +711,11 @@ dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids = do
let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
return (do_premap ids
env_ty
- (mkCorePairTy env_ty unitTy)
+ (mkCorePairTy env_ty unitTy)
res_ty
core_map
core_body,
- env_ids')
+ env_ids')
dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
let
@@ -748,50 +742,50 @@ dsCmdLStmt ids local_vars out_ids cmd env_ids
= dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
dsCmdStmt
- :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this statement
- -> [Id] -- list of vars in the output of this statement
- -> CmdStmt Id -- statement to desugar
- -> [Id] -- list of vars in the input to this statement
- -- This is typically fed back,
- -- so don't pull on it too early
- -> DsM (CoreExpr, -- desugared expression
- IdSet) -- subset of local vars that occur free
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> [Id] -- list of vars in the output of this statement
+ -> CmdStmt Id -- statement to desugar
+ -> [Id] -- list of vars in the input to this statement
+ -- This is typically fed back,
+ -- so don't pull on it too early
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- subset of local vars that occur free
-- D; xs1 |-a c : () --> t
-- D; xs' |-a do { ss } : t'
-- ------------------------------
-- D; xs |-a do { c; ss } : t'
--
--- ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
--- (first c >>> arr snd) >>> ss
+-- ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
+-- (first c >>> arr snd) >>> ss
dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
core_mux <- matchEnv env_ids
(mkCorePairExpr
- (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
- (mkBigCoreVarTup out_ids))
+ (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
+ (mkBigCoreVarTup out_ids))
let
- in_ty = mkBigCoreVarTupTy env_ids
- in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
- out_ty = mkBigCoreVarTupTy out_ids
- before_c_ty = mkCorePairTy in_ty1 out_ty
- after_c_ty = mkCorePairTy c_ty out_ty
+ in_ty = mkBigCoreVarTupTy env_ids
+ in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
+ out_ty = mkBigCoreVarTupTy out_ids
+ before_c_ty = mkCorePairTy in_ty1 out_ty
+ after_c_ty = mkCorePairTy c_ty out_ty
snd_fn <- mkSndExpr c_ty out_ty
return (do_premap ids in_ty before_c_ty out_ty core_mux $
- do_compose ids before_c_ty after_c_ty out_ty
- (do_first ids in_ty1 c_ty out_ty core_cmd) $
- do_arr ids after_c_ty out_ty snd_fn,
- extendVarSetList fv_cmd out_ids)
+ do_compose ids before_c_ty after_c_ty out_ty
+ (do_first ids in_ty1 c_ty out_ty core_cmd) $
+ do_arr ids after_c_ty out_ty snd_fn,
+ extendVarSetList fv_cmd out_ids)
-- D; xs1 |-a c : () --> t
--- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p)
+-- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p)
-- -----------------------------------
-- D; xs |-a do { p <- c; ss } : t'
--
--- ---> premap (\ (xs) -> (((xs1),()),(xs2)))
--- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
+-- ---> premap (\ (xs) -> (((xs1),()),(xs2)))
+-- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
--
-- It would be simpler and more consistent to do this using second,
-- but that's likely to be defined in terms of first.
@@ -799,53 +793,53 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy (hsLPatType pat) cmd
let
- pat_ty = hsLPatType pat
- pat_vars = mkVarSet (collectPatBinders pat)
- env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
- env_ty2 = mkBigCoreVarTupTy env_ids2
+ pat_ty = hsLPatType pat
+ pat_vars = mkVarSet (collectPatBinders pat)
+ env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
+ env_ty2 = mkBigCoreVarTupTy env_ids2
-- multiplexing function
- -- \ (xs) -> (((xs1),()),(xs2))
+ -- \ (xs) -> (((xs1),()),(xs2))
core_mux <- matchEnv env_ids
(mkCorePairExpr
- (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
- (mkBigCoreVarTup env_ids2))
+ (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
+ (mkBigCoreVarTup env_ids2))
-- projection function
- -- \ (p, (xs2)) -> (zs)
+ -- \ (p, (xs2)) -> (zs)
env_id <- newSysLocalDs env_ty2
uniqs <- newUniqueSupply
let
- after_c_ty = mkCorePairTy pat_ty env_ty2
- out_ty = mkBigCoreVarTupTy out_ids
- body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
-
+ after_c_ty = mkCorePairTy pat_ty env_ty2
+ out_ty = mkBigCoreVarTupTy out_ids
+ body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
+
fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
pat_id <- selectSimpleMatchVarL pat
match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
pair_id <- newSysLocalDs after_c_ty
let
- proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
+ proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
-- put it all together
let
- in_ty = mkBigCoreVarTupTy env_ids
- in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
- in_ty2 = mkBigCoreVarTupTy env_ids2
- before_c_ty = mkCorePairTy in_ty1 in_ty2
+ in_ty = mkBigCoreVarTupTy env_ids
+ in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
+ in_ty2 = mkBigCoreVarTupTy env_ids2
+ before_c_ty = mkCorePairTy in_ty1 in_ty2
return (do_premap ids in_ty before_c_ty out_ty core_mux $
- do_compose ids before_c_ty after_c_ty out_ty
- (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
- do_arr ids after_c_ty out_ty proj_expr,
- fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))
+ do_compose ids before_c_ty after_c_ty out_ty
+ (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
+ do_arr ids after_c_ty out_ty proj_expr,
+ fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))
-- D; xs' |-a do { ss } : t
-- --------------------------------------
-- D; xs |-a do { let binds; ss } : t
--
--- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
+-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
-- build a new environment using the let bindings
@@ -853,24 +847,24 @@ dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
-- match the old environment against the input
core_map <- matchEnv env_ids core_binds
return (do_arr ids
- (mkBigCoreVarTupTy env_ids)
- (mkBigCoreVarTupTy out_ids)
- core_map,
- exprFreeIds core_binds `intersectVarSet` local_vars)
+ (mkBigCoreVarTupTy env_ids)
+ (mkBigCoreVarTupTy out_ids)
+ core_map,
+ exprFreeIds core_binds `intersectVarSet` local_vars)
-- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
-- D; xs' |-a do { ss' } : t
-- ------------------------------------
-- D; xs |-a do { rec ss; ss' } : t
--
--- xs1 = xs' /\ defs(ss)
--- xs2 = xs' - defs(ss)
--- ys1 = ys - defs(ss)
--- ys2 = ys /\ defs(ss)
+-- xs1 = xs' /\ defs(ss)
+-- xs2 = xs' - defs(ss)
+-- ys1 = ys - defs(ss)
+-- ys2 = ys /\ defs(ss)
--
--- ---> arr (\(xs) -> ((ys1),(xs2))) >>>
--- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
--- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
+-- ---> arr (\(xs) -> ((ys1),(xs2))) >>>
+-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
+-- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
dsCmdStmt ids local_vars out_ids
(RecStmt { recS_stmts = stmts
@@ -925,20 +919,20 @@ dsCmdStmt ids local_vars out_ids
dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
--- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
--- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
+-- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
+-- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
dsRecCmd
- :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this statement
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
-> [CmdLStmt Id] -- list of statements inside the RecCmd
- -> [Id] -- list of vars defined here and used later
- -> [HsExpr Id] -- expressions corresponding to later_ids
- -> [Id] -- list of vars fed back through the loop
- -> [HsExpr Id] -- expressions corresponding to rec_ids
- -> DsM (CoreExpr, -- desugared statement
- IdSet, -- subset of local vars that occur free
- [Id]) -- same local vars as a list
+ -> [Id] -- list of vars defined here and used later
+ -> [HsExpr Id] -- expressions corresponding to later_ids
+ -> [Id] -- list of vars fed back through the loop
+ -> [HsExpr Id] -- expressions corresponding to rec_ids
+ -> DsM (CoreExpr, -- desugared statement
+ IdSet, -- subset of local vars that occur free
+ [Id]) -- same local vars as a list
dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
let
@@ -1006,25 +1000,25 @@ two environments (no stack)
\begin{code}
dsfixCmdStmts
- :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this statement
- -> [Id] -- output vars of these statements
- -> [CmdLStmt Id] -- statements to desugar
- -> DsM (CoreExpr, -- desugared expression
- IdSet, -- subset of local vars that occur free
- [Id]) -- same local vars as a list
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> [Id] -- output vars of these statements
+ -> [CmdLStmt Id] -- statements to desugar
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet, -- subset of local vars that occur free
+ [Id]) -- same local vars as a list
dsfixCmdStmts ids local_vars out_ids stmts
= trimInput (dsCmdStmts ids local_vars out_ids stmts)
dsCmdStmts
- :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this statement
- -> [Id] -- output vars of these statements
- -> [CmdLStmt Id] -- statements to desugar
- -> [Id] -- list of vars in the input to these statements
- -> DsM (CoreExpr, -- desugared expression
- IdSet) -- subset of local vars that occur free
+ :: DsCmdEnv -- arrow combinators
+ -> IdSet -- set of local vars available to this statement
+ -> [Id] -- output vars of these statements
+ -> [CmdLStmt Id] -- statements to desugar
+ -> [Id] -- list of vars in the input to these statements
+ -> DsM (CoreExpr, -- desugared expression
+ IdSet) -- subset of local vars that occur free
dsCmdStmts ids local_vars out_ids [stmt] env_ids
= dsCmdLStmt ids local_vars out_ids stmt env_ids
@@ -1050,11 +1044,11 @@ Match a list of expressions against a list of patterns, left-to-right.
\begin{code}
matchSimplys :: [CoreExpr] -- Scrutinees
- -> HsMatchContext Name -- Match kind
- -> [LPat Id] -- Patterns they should match
- -> CoreExpr -- Return this if they all match
- -> CoreExpr -- Return this if they don't
- -> DsM CoreExpr
+ -> HsMatchContext Name -- Match kind
+ -> [LPat Id] -- Patterns they should match
+ -> CoreExpr -- Return this if they all match
+ -> CoreExpr -- Return this if they don't
+ -> DsM CoreExpr
matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
match_code <- matchSimplys exps ctxt pats result_expr fail_expr
@@ -1068,13 +1062,13 @@ List of leaf expressions, with set of variables bound in each
leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]
leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
= let
- defined_vars = mkVarSet (collectPatsBinders pats)
- `unionVarSet`
- mkVarSet (collectLocalBinders binds)
+ defined_vars = mkVarSet (collectPatsBinders pats)
+ `unionVarSet`
+ mkVarSet (collectLocalBinders binds)
in
- [(body,
- mkVarSet (collectLStmtsBinders stmts)
- `unionVarSet` defined_vars)
+ [(body,
+ mkVarSet (collectLStmtsBinders stmts)
+ `unionVarSet` defined_vars)
| L _ (GRHS stmts body) <- grhss]
\end{code}
@@ -1089,7 +1083,7 @@ replaceLeavesMatch
LMatch Id (Located (body' Id))) -- updated match
replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
= let
- (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
+ (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
(leaves', L loc (Match pat mt (GRHSs grhss' binds)))
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 37c16325e0..a8d37a4bdd 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -11,12 +11,6 @@ lower levels it is preserved with @let@/@letrec@s).
\begin{code}
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsEvBinds
@@ -24,15 +18,15 @@ module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr( dsLExpr )
-import {-# SOURCE #-} Match( matchWrapper )
+import {-# SOURCE #-} DsExpr( dsLExpr )
+import {-# SOURCE #-} Match( matchWrapper )
import DsMonad
import DsGRHSs
import DsUtils
-import HsSyn -- lots of things
-import CoreSyn -- lots of things
+import HsSyn -- lots of things
+import CoreSyn -- lots of things
import Literal ( Literal(MachStr) )
import CoreSubst
import OccurAnal ( occurAnalyseExpr )
@@ -54,9 +48,9 @@ import Coercion hiding (substCo)
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon )
import Id
import Class
-import DataCon ( dataConWorkId )
+import DataCon ( dataConWorkId )
import Name
-import MkId ( seqId )
+import MkId ( seqId )
import Var
import VarSet
import Rules
@@ -78,9 +72,9 @@ import Control.Monad(liftM)
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -106,17 +100,17 @@ dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless
= do { dflags <- getDynFlags
; core_expr <- dsLExpr expr
- -- Dictionary bindings are always VarBinds,
- -- so we only need do this here
+ -- Dictionary bindings are always VarBinds,
+ -- so we only need do this here
; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
- | otherwise = var
+ | otherwise = var
; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }
dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
, fun_co_fn = co_fn, fun_tick = tick
, fun_infix = inf })
- = do { dflags <- getDynFlags
+ = do { dflags <- getDynFlags
; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
; let body' = mkOptTickBox tick body
; rhs <- dsHsWrapper co_fn (mkLams args body')
@@ -125,17 +119,17 @@ dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
, pat_ticks = (rhs_tick, var_ticks) })
- = do { body_expr <- dsGuarded grhss ty
+ = do { body_expr <- dsGuarded grhss ty
; let body' = mkOptTickBox rhs_tick body_expr
; sel_binds <- mkSelectorBinds var_ticks pat body'
- -- We silently ignore inline pragmas; no makeCorePair
- -- Not so cool, but really doesn't matter
+ -- We silently ignore inline pragmas; no makeCorePair
+ -- Not so cool, but really doesn't matter
; return (toOL sel_binds) }
- -- A common case: one exported variable
- -- Non-recursive bindings come through this way
- -- So do self-recursive bindings, and recursive bindings
- -- that have been chopped up with type signatures
+ -- A common case: one exported variable
+ -- Non-recursive bindings come through this way
+ -- So do self-recursive bindings, and recursive bindings
+ -- that have been chopped up with type signatures
dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = [export]
, abs_ev_binds = ev_binds, abs_binds = binds })
@@ -143,21 +137,21 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abe_mono = local, abe_prags = prags } <- export
= do { dflags <- getDynFlags
; bind_prs <- ds_lhs_binds binds
- ; let core_bind = Rec (fromOL bind_prs)
+ ; let core_bind = Rec (fromOL bind_prs)
; ds_binds <- dsTcEvBinds ev_binds
; rhs <- dsHsWrapper wrap $ -- Usually the identity
- mkLams tyvars $ mkLams dicts $
- mkCoreLets ds_binds $
+ mkLams tyvars $ mkLams dicts $
+ mkCoreLets ds_binds $
Let core_bind $
Var local
-
- ; (spec_binds, rules) <- dsSpecs rhs prags
- ; let global' = addIdSpecialisations global rules
- main_bind = makeCorePair dflags global' (isDefaultMethod prags)
- (dictArity dicts) rhs
-
- ; return (main_bind `consOL` spec_binds) }
+ ; (spec_binds, rules) <- dsSpecs rhs prags
+
+ ; let global' = addIdSpecialisations global rules
+ main_bind = makeCorePair dflags global' (isDefaultMethod prags)
+ (dictArity dicts) rhs
+
+ ; return (main_bind `consOL` spec_binds) }
dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports, abs_ev_binds = ev_binds
@@ -167,39 +161,39 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
; bind_prs <- ds_lhs_binds binds
; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
| (lcl_id, rhs) <- fromOL bind_prs ]
- -- Monomorphic recursion possible, hence Rec
+ -- Monomorphic recursion possible, hence Rec
- locals = map abe_mono exports
- tup_expr = mkBigCoreVarTup locals
- tup_ty = exprType tup_expr
+ locals = map abe_mono exports
+ tup_expr = mkBigCoreVarTup locals
+ tup_ty = exprType tup_expr
; ds_binds <- dsTcEvBinds ev_binds
- ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
- mkCoreLets ds_binds $
- Let core_bind $
- tup_expr
+ ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
+ mkCoreLets ds_binds $
+ Let core_bind $
+ tup_expr
- ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
+ ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
- ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
+ ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
- = do { tup_id <- newSysLocalDs tup_ty
- ; rhs <- dsHsWrapper wrap $
+ = do { tup_id <- newSysLocalDs tup_ty
+ ; rhs <- dsHsWrapper wrap $
mkLams tyvars $ mkLams dicts $
- mkTupleSelector locals local tup_id $
- mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
+ mkTupleSelector locals local tup_id $
+ mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
- ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
- ; let global' = (global `setInlinePragma` defaultInlinePragma)
+ ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
+ ; let global' = (global `setInlinePragma` defaultInlinePragma)
`addIdSpecialisations` rules
-- Kill the INLINE pragma because it applies to
-- the user written (local) function. The global
- -- Id is just the selector. Hmm.
- ; return ((global', rhs) `consOL` spec_binds) }
+ -- Id is just the selector. Hmm.
+ ; return ((global', rhs) `consOL` spec_binds) }
; export_binds_s <- mapM mk_bind exports
- ; return ((poly_tup_id, poly_tup_rhs) `consOL`
- concatOL export_binds_s) }
+ ; return ((poly_tup_id, poly_tup_rhs) `consOL`
+ concatOL export_binds_s) }
where
inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
-- the inline pragma from the source
@@ -217,14 +211,14 @@ dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind"
------------------------
makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
makeCorePair dflags gbl_id is_default_method dict_arity rhs
- | is_default_method -- Default methods are *always* inlined
+ | is_default_method -- Default methods are *always* inlined
= (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
| otherwise
= case inlinePragmaSpec inline_prag of
- EmptyInlineSpec -> (gbl_id, rhs)
- NoInline -> (gbl_id, rhs)
- Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+ EmptyInlineSpec -> (gbl_id, rhs)
+ NoInline -> (gbl_id, rhs)
+ Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
Inline -> inline_pair
where
@@ -232,8 +226,8 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
inlinable_unf = mkInlinableUnfolding dflags rhs
inline_pair
| Just arity <- inlinePragmaSat inline_prag
- -- Add an Unfolding for an INLINE (but not for NOINLINE)
- -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
+ -- Add an Unfolding for an INLINE (but not for NOINLINE)
+ -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
, let real_arity = dict_arity + arity
-- NB: The arity in the InlineRule takes account of the dictionaries
= ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
@@ -264,22 +258,22 @@ Note [Rules and inlining]
Common special case: no type or dictionary abstraction
This is a bit less trivial than you might suppose
The naive way woudl be to desguar to something like
- f_lcl = ...f_lcl... -- The "binds" from AbsBinds
- M.f = f_lcl -- Generated from "exports"
+ f_lcl = ...f_lcl... -- The "binds" from AbsBinds
+ M.f = f_lcl -- Generated from "exports"
But we don't want that, because if M.f isn't exported,
-it'll be inlined unconditionally at every call site (its rhs is
-trivial). That would be ok unless it has RULES, which would
+it'll be inlined unconditionally at every call site (its rhs is
+trivial). That would be ok unless it has RULES, which would
thereby be completely lost. Bad, bad, bad.
Instead we want to generate
- M.f = ...f_lcl...
- f_lcl = M.f
-Now all is cool. The RULES are attached to M.f (by SimplCore),
+ M.f = ...f_lcl...
+ f_lcl = M.f
+Now all is cool. The RULES are attached to M.f (by SimplCore),
and f_lcl is rapidly inlined away.
This does not happen in the same way to polymorphic binds,
because they desugar to
- M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
+ M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
Although I'm a bit worried about whether full laziness might
float the f_lcl binding out and then inline M.f at its call site
@@ -297,7 +291,7 @@ So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
instance RealFrac Float where
{-# SPECIALIZE round :: Float -> Int #-}
-The top-level AbsBinds for $cround has no tyvars or dicts (because the
+The top-level AbsBinds for $cround has no tyvars or dicts (because the
instance does not). But the method is locally overloaded!
Note [Abstracting over tyvars only]
@@ -305,36 +299,36 @@ Note [Abstracting over tyvars only]
When abstracting over type variable only (not dictionaries), we don't really need to
built a tuple and select from it, as we do in the general case. Instead we can take
- AbsBinds [a,b] [ ([a,b], fg, fl, _),
- ([b], gg, gl, _) ]
- { fl = e1
- gl = e2
- h = e3 }
+ AbsBinds [a,b] [ ([a,b], fg, fl, _),
+ ([b], gg, gl, _) ]
+ { fl = e1
+ gl = e2
+ h = e3 }
and desugar it to
- fg = /\ab. let B in e1
- gg = /\b. let a = () in let B in S(e2)
- h = /\ab. let B in e3
+ fg = /\ab. let B in e1
+ gg = /\b. let a = () in let B in S(e2)
+ h = /\ab. let B in e3
where B is the *non-recursive* binding
- fl = fg a b
- gl = gg b
- h = h a b -- See (b); note shadowing!
+ fl = fg a b
+ gl = gg b
+ h = h a b -- See (b); note shadowing!
Notice (a) g has a different number of type variables to f, so we must
- use the mkArbitraryType thing to fill in the gaps.
- We use a type-let to do that.
+ use the mkArbitraryType thing to fill in the gaps.
+ We use a type-let to do that.
- (b) The local variable h isn't in the exports, and rather than
- clone a fresh copy we simply replace h by (h a b), where
- the two h's have different types! Shadowing happens here,
- which looks confusing but works fine.
+ (b) The local variable h isn't in the exports, and rather than
+ clone a fresh copy we simply replace h by (h a b), where
+ the two h's have different types! Shadowing happens here,
+ which looks confusing but works fine.
- (c) The result is *still* quadratic-sized if there are a lot of
- small bindings. So if there are more than some small
- number (10), we filter the binding set B by the free
- variables of the particular RHS. Tiresome.
+ (c) The result is *still* quadratic-sized if there are a lot of
+ small bindings. So if there are more than some small
+ number (10), we filter the binding set B by the free
+ variables of the particular RHS. Tiresome.
Why got to this trouble? It's a common case, and it removes the
quadratic-sized tuple desugaring. Less clutter, hopefullly faster
@@ -350,13 +344,13 @@ Consider
foo x = ...
If (foo d) ever gets floated out as a common sub-expression (which can
-happen as a result of method sharing), there's a danger that we never
+happen as a result of method sharing), there's a danger that we never
get to do the inlining, which is a Terribly Bad thing given that the
user said "inline"!
To avoid this we pre-emptively eta-expand the definition, so that foo
has the arity with which it is declared in the source code. In this
-example it has arity 2 (one for the Eq and one for x). Doing this
+example it has arity 2 (one for the Eq and one for x). Doing this
should mean that (foo d) is a PAP and we don't share it.
Note [Nested arities]
@@ -379,8 +373,8 @@ thought!
Note [Implementing SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Example:
- f :: (Eq a, Ix b) => a -> b -> Bool
- {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
+ f :: (Eq a, Ix b) => a -> b -> Bool
+ {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
f = <poly_rhs>
From this the typechecker generates
@@ -390,7 +384,7 @@ From this the typechecker generates
SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
-> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
-Note that wrap_fn can transform *any* function with the right type prefix
+Note that wrap_fn can transform *any* function with the right type prefix
forall ab. (Eq a, Ix b) => XXX
regardless of XXX. It's sort of polymorphic in XXX. This is
useful: we use the same wrapper to transform each of the class ops, as
@@ -398,26 +392,26 @@ well as the dict.
From these we generate:
- Rule: forall p, q, (dp:Ix p), (dq:Ix q).
+ Rule: forall p, q, (dp:Ix p), (dq:Ix q).
f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
- Spec bind: f_spec = wrap_fn <poly_rhs>
+ Spec bind: f_spec = wrap_fn <poly_rhs>
-Note that
+Note that
* The LHS of the rule may mention dictionary *expressions* (eg
$dfIxPair dp dq), and that is essential because the dp, dq are
needed on the RHS.
- * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
+ * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
can fully specialise it.
\begin{code}
------------------------
dsSpecs :: CoreExpr -- Its rhs
-> TcSpecPrags
- -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
- , [CoreRule] ) -- Rules for the Global Ids
+ -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
+ , [CoreRule] ) -- Rules for the Global Ids
-- See Note [Implementing SPECIALISE pragmas]
dsSpecs _ IsDefaultMethod = return (nilOL, [])
dsSpecs poly_rhs (SpecPrags sps)
@@ -425,29 +419,29 @@ dsSpecs poly_rhs (SpecPrags sps)
; let (spec_binds_s, rules) = unzip pairs
; return (concatOL spec_binds_s, rules) }
-dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
- -- Nothing => RULE is for an imported Id
- -- rhs is in the Id's unfolding
+dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
+ -- Nothing => RULE is for an imported Id
+ -- rhs is in the Id's unfolding
-> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| isJust (isClassOpId_maybe poly_id)
- = putSrcSpanDs loc $
- do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector")
+ = putSrcSpanDs loc $
+ do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector")
<+> quotes (ppr poly_id))
; return Nothing } -- There is no point in trying to specialise a class op
- -- Moreover, classops don't (currently) have an inl_sat arity set
- -- (it would be Just 0) and that in turn makes makeCorePair bleat
+ -- Moreover, classops don't (currently) have an inl_sat arity set
+ -- (it would be Just 0) and that in turn makes makeCorePair bleat
- | no_act_spec && isNeverActive rule_act
- = putSrcSpanDs loc $
+ | no_act_spec && isNeverActive rule_act
+ = putSrcSpanDs loc $
do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")
<+> quotes (ppr poly_id))
; return Nothing } -- Function is NOINLINE, and the specialiation inherits that
- -- See Note [Activation pragmas for SPECIALISE]
+ -- See Note [Activation pragmas for SPECIALISE]
| otherwise
- = putSrcSpanDs loc $
+ = putSrcSpanDs loc $
do { uniq <- newUnique
; let poly_name = idName poly_id
spec_occ = mkSpecOcc (getOccName poly_name)
@@ -467,14 +461,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
unf_fvs = stableUnfoldingVars fn_unf `orElse` emptyVarSet
in_scope = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args)
spec_unf = specUnfolding dflags (mkEmptySubst in_scope) bndrs args fn_unf
- spec_id = mkLocalId spec_name spec_ty
- `setInlinePragma` inl_prag
- `setIdUnfolding` spec_unf
+ spec_id = mkLocalId spec_name spec_ty
+ `setInlinePragma` inl_prag
+ `setIdUnfolding` spec_unf
rule = mkRule False {- Not auto -} is_local_id
(mkFastString ("SPEC " ++ showPpr dflags poly_name))
- rule_act poly_name
- rule_bndrs args
- (mkVarApps (Var spec_id) bndrs)
+ rule_act poly_name
+ rule_bndrs args
+ (mkVarApps (Var spec_id) bndrs)
; spec_rhs <- dsHsWrapper spec_co poly_rhs
@@ -489,21 +483,21 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
where
is_local_id = isJust mb_poly_rhs
poly_rhs | Just rhs <- mb_poly_rhs
- = rhs -- Local Id; this is its rhs
+ = rhs -- Local Id; this is its rhs
| Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
= unfolding -- Imported Id; this is its unfolding
- -- Use realIdUnfolding so we get the unfolding
- -- even when it is a loop breaker.
- -- We want to specialise recursive functions!
+ -- Use realIdUnfolding so we get the unfolding
+ -- even when it is a loop breaker.
+ -- We want to specialise recursive functions!
| otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
- -- The type checker has checked that it *has* an unfolding
+ -- The type checker has checked that it *has* an unfolding
id_inl = idInlinePragma poly_id
-- See Note [Activation pragmas for SPECIALISE]
inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl
| not is_local_id -- See Note [Specialising imported functions]
- -- in OccurAnal
+ -- in OccurAnal
, isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
| otherwise = id_inl
-- Get the INLINE pragma from SPECIALISE declaration, or,
@@ -522,7 +516,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
specOnInline :: Name -> MsgDoc
-specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:")
+specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:")
<+> quotes (ppr f)
\end{code}
@@ -535,7 +529,7 @@ From a user SPECIALISE pragma for f, we generate
We need two pragma-like things:
-* spec_fn's inline pragma: inherited from f's inline pragma (ignoring
+* spec_fn's inline pragma: inherited from f's inline pragma (ignoring
activation on SPEC), unless overriden by SPEC INLINE
* Activation of RULE: from SPECIALISE pragma (if activation given)
@@ -557,7 +551,7 @@ SPEC [n] f :: ty [n] NOINLINE [k]
copy f's prag
INLINE [k] f
-SPEC [n] f :: ty [n] INLINE [k]
+SPEC [n] f :: ty [n] INLINE [k]
copy f's prag
SPEC INLINE [n] f :: ty [n] INLINE [n]
@@ -569,9 +563,9 @@ SPEC f :: ty [n] INLINE [k]
%************************************************************************
-%* *
+%* *
\subsection{Adding inline pragmas}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -598,11 +592,11 @@ decomposeRuleLhs orig_bndrs orig_lhs
Right (bndrs1, fn_var, args)
| Case scrut bndr ty [(DEFAULT, _, body)] <- fun
- , isDeadBinder bndr -- Note [Matching seqId]
+ , isDeadBinder bndr -- Note [Matching seqId]
, let args' = [Type (idType bndr), Type ty, scrut, body]
= Right (bndrs1, seqId, args' ++ args)
- | otherwise
+ | otherwise
= Left bad_shape_msg
where
lhs1 = drop_dicts orig_lhs
@@ -623,7 +617,7 @@ decomposeRuleLhs orig_bndrs orig_lhs
2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
, text "Orig lhs:" <+> ppr orig_lhs])
dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
- , ptext (sLit "is not bound in RULE lhs")])
+ , ptext (sLit "is not bound in RULE lhs")])
2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
, text "Orig lhs:" <+> ppr orig_lhs
, text "optimised lhs:" <+> ppr lhs2 ])
@@ -633,12 +627,12 @@ decomposeRuleLhs orig_bndrs orig_lhs
| otherwise = ptext (sLit "variable") <+> quotes (ppr bndr)
drop_dicts :: CoreExpr -> CoreExpr
- drop_dicts e
+ drop_dicts e
= wrap_lets needed bnds body
where
needed = orig_bndr_set `minusVarSet` exprFreeVars body
(bnds, body) = split_lets (occurAnalyseExpr e)
- -- The occurAnalyseExpr drops dead bindings which is
+ -- The occurAnalyseExpr drops dead bindings which is
-- crucial to ensure that every binding is used later;
-- which in turn makes wrap_lets work right
@@ -663,22 +657,22 @@ decomposeRuleLhs orig_bndrs orig_lhs
Note [Decomposing the left-hand side of a RULE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are several things going on here.
+There are several things going on here.
* drop_dicts: see Note [Drop dictionary bindings on rule LHS]
* simpleOptExpr: see Note [Simplify rule LHS]
* extra_dict_bndrs: see Note [Free dictionaries]
Note [Drop dictionary bindings on rule LHS]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-drop_dicts drops dictionary bindings on the LHS where possible.
+drop_dicts drops dictionary bindings on the LHS where possible.
E.g. let d:Eq [Int] = $fEqList $fEqInt in f d
--> f d
- Reasoning here is that there is only one d:Eq [Int], and so we can
+ Reasoning here is that there is only one d:Eq [Int], and so we can
quantify over it. That makes 'd' free in the LHS, but that is later
picked up by extra_dict_bndrs (Note [Dead spec binders]).
NB 1: We can only drop the binding if the RHS doesn't bind
- one of the orig_bndrs, which we assume occur on RHS.
+ one of the orig_bndrs, which we assume occur on RHS.
Example
f :: (Eq a) => b -> a -> a
{-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
@@ -687,7 +681,7 @@ drop_dicts drops dictionary bindings on the LHS where possible.
Of course, the ($dfEqlist d) in the pattern makes it less likely
to match, but ther is no other way to get d:Eq a
- NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
+ NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
the evidence bindings to be wrapped around the outside of the
LHS. (After simplOptExpr they'll usually have been inlined.)
dsHsWrapper does dependency analysis, so that civilised ones
@@ -728,39 +722,39 @@ Note [Simplify rule LHS]
~~~~~~~~~~~~~~~~~~~~~~~~
simplOptExpr occurrence-analyses and simplifies the LHS:
- (a) Inline any remaining dictionary bindings (which hopefully
+ (a) Inline any remaining dictionary bindings (which hopefully
occur just once)
(b) Substitute trivial lets so that they don't get in the way
- Note that we substitute the function too; we might
+ Note that we substitute the function too; we might
have this as a LHS: let f71 = M.f Int in f71
- (c) Do eta reduction. To see why, consider the fold/build rule,
+ (c) Do eta reduction. To see why, consider the fold/build rule,
which without simplification looked like:
fold k z (build (/\a. g a)) ==> ...
This doesn't match unless you do eta reduction on the build argument.
Similarly for a LHS like
- augment g (build h)
+ augment g (build h)
we do not want to get
- augment (\a. g a) (build h)
+ augment (\a. g a) (build h)
otherwise we don't match when given an argument like
augment (\a. h a a) (build h)
Note [Matching seqId]
~~~~~~~~~~~~~~~~~~~
The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
-and this code turns it back into an application of seq!
+and this code turns it back into an application of seq!
See Note [Rules for seq] in MkId for the details.
Note [Unused spec binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
- f :: a -> a
- {-# SPECIALISE f :: Eq a => a -> a #-}
+ f :: a -> a
+ {-# SPECIALISE f :: Eq a => a -> a #-}
It's true that this *is* a more specialised type, but the rule
we get is something like this:
- f_spec d = f
- RULE: f = f_spec d
+ f_spec d = f
+ RULE: f = f_spec d
Note that the rule is bogus, because it mentions a 'd' that is
not bound on the LHS! But it's a silly specialisation anyway, because
the constraint is unused. We could bind 'd' to (error "unused")
@@ -769,22 +763,22 @@ a mistake. That's what the isDeadBinder call detects.
Note [Free dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~
-When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
-which is presumably in scope at the function definition site, we can quantify
+When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
+which is presumably in scope at the function definition site, we can quantify
over it too. *Any* dict with that type will do.
So for example when you have
- f :: Eq a => a -> a
- f = <rhs>
- {-# SPECIALISE f :: Int -> Int #-}
+ f :: Eq a => a -> a
+ f = <rhs>
+ {-# SPECIALISE f :: Int -> Int #-}
Then we get the SpecPrag
- SpecPrag (f Int dInt)
+ SpecPrag (f Int dInt)
And from that we want the rule
-
- RULE forall dInt. f Int dInt = f_spec
- f_spec = let f = <rhs> in f Int dInt
+
+ RULE forall dInt. f Int dInt = f_spec
+ f_spec = let f = <rhs> in f Int dInt
But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
Name, and you can't bind them in a lambda or forall without getting things
@@ -794,23 +788,23 @@ as the old one, but with an Internal name and no IdInfo.
%************************************************************************
-%* *
- Desugaring evidence
-%* *
+%* *
+ Desugaring evidence
+%* *
%************************************************************************
\begin{code}
dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr
-dsHsWrapper WpHole e = return e
+dsHsWrapper WpHole e = return e
dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
return (mkCoreLets bs e)
dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e
dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational)
dsTcCoercion co (mkCast e)
-dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
-dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
+dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
+dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm)
--------------------------------------
@@ -830,7 +824,7 @@ sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
where
edges :: [(EvBind, EvVar, [EvVar])]
- edges = foldrBag ((:) . mk_node) [] bs
+ edges = foldrBag ((:) . mk_node) [] bs
mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term))
@@ -840,7 +834,7 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvId v) = return (Var v)
-dsEvTerm (EvCast tm co)
+dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
; dsTcCoercion co $ mkCast tm' }
-- 'v' is always a lifted evidence variable so it is
@@ -856,29 +850,29 @@ dsEvTerm (EvTupleSel v n)
= do { tm' <- dsEvTerm v
; let scrut_ty = exprType tm'
(tc, tys) = splitTyConApp scrut_ty
- Just [dc] = tyConDataCons_maybe tc
- xs = mkTemplateLocals tys
+ Just [dc] = tyConDataCons_maybe tc
+ xs = mkTemplateLocals tys
the_x = getNth xs n
; ASSERT( isTupleTyCon tc )
return $
Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }
-dsEvTerm (EvTupleMk tms)
+dsEvTerm (EvTupleMk tms)
= do { tms' <- mapM dsEvTerm tms
; let tys = map exprType tms'
; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' }
- where
+ where
dc = tupleCon ConstraintTuple (length tms)
dsEvTerm (EvSuperClass d n)
= do { d' <- dsEvTerm d
; let (cls, tys) = getClassPredTys (exprType d')
- sc_sel_id = classSCSelId cls n -- Zero-indexed
+ sc_sel_id = classSCSelId cls n -- Zero-indexed
; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
where
dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
- where
+ where
errorId = rUNTIME_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
@@ -889,7 +883,7 @@ dsEvTerm (EvLit l) =
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
--- This is the crucial function that moves
+-- This is the crucial function that moves
-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
-- e.g. dsTcCoercion (trans g1 g2) k
-- = case g1 of EqBox g1# ->
@@ -927,7 +921,7 @@ ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
-- If the incoming TcCoercion if of type (a ~ b) (resp. Coercible a b)
-- the result is of type (a ~# b) (reps. a ~# b)
-- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) (resp. and so on)
--- No need for InScope set etc because the
+-- No need for InScope set etc because the
ds_tc_coercion subst tc_co
= go tc_co
where
@@ -978,7 +972,7 @@ Note [Simple coercions]
We have a special case for coercions that are simple variables.
Suppose cv :: a ~ b is in scope
Lacking the special case, if we see
- f a b cv
+ f a b cv
we'd desguar to
f a b (case cv of EqBox (cv# :: a ~# b) -> EqBox cv#)
which is a bit stupid. The special case does the obvious thing.
@@ -990,7 +984,7 @@ This turns out to be important when desugaring the LHS of a RULE
{-# RULES "normalise" normalise = normalise_Double #-}
Then the RULE we want looks like
- forall a, (cv:a~Scalar a).
+ forall a, (cv:a~Scalar a).
normalise a cv = normalise_Double
But without the special case we generate the redundant box/unbox,
which simpleOpt (currently) doesn't remove. So the rule never matches.
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index c52b917efd..a269374bed 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -9,28 +9,22 @@ This module exports some utility functions of no great interest.
\begin{code}
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-- | Utility functions for constructing Core syntax, principally for desugaring
module DsUtils (
- EquationInfo(..),
- firstPat, shiftEqns,
+ EquationInfo(..),
+ firstPat, shiftEqns,
- MatchResult(..), CanItFail(..), CaseAlt(..),
- cantFailMatchResult, alwaysFailMatchResult,
- extractMatchResult, combineMatchResults,
- adjustMatchResult, adjustMatchResultDs,
- mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
- matchCanFail, mkEvalMatchResult,
- mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
- wrapBind, wrapBinds,
+ MatchResult(..), CanItFail(..), CaseAlt(..),
+ cantFailMatchResult, alwaysFailMatchResult,
+ extractMatchResult, combineMatchResults,
+ adjustMatchResult, adjustMatchResultDs,
+ mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
+ matchCanFail, mkEvalMatchResult,
+ mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
+ wrapBind, wrapBinds,
- mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,
+ mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,
seqVar,
@@ -40,13 +34,13 @@ module DsUtils (
mkSelectorBinds,
- selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
+ selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
mkOptTickBox, mkBinaryTickBox
) where
#include "HsVersions.h"
-import {-# SOURCE #-} Match ( matchSimply )
+import {-# SOURCE #-} Match ( matchSimply )
import HsSyn
import TcHsSyn
@@ -85,9 +79,9 @@ import Control.Monad ( zipWithM )
%************************************************************************
-%* *
+%* *
\subsection{ Selecting match variables}
-%* *
+%* *
%************************************************************************
We're about to match against some patterns. We want to make some
@@ -105,13 +99,13 @@ selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
--
-- OLD, but interesting note:
-- But even if it is a variable, its type might not match. Consider
--- data T a where
--- T1 :: Int -> T Int
--- T2 :: a -> T a
+-- data T a where
+-- T1 :: Int -> T Int
+-- T2 :: a -> T a
--
--- f :: T a -> a -> Int
--- f (T1 i) (x::Int) = x
--- f (T2 i) (y::a) = 0
+-- f :: T a -> a -> Int
+-- f (T1 i) (x::Int) = x
+-- f (T2 i) (y::a) = 0
-- Then we must not choose (x::Int) as the matching variable!
-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
@@ -125,7 +119,7 @@ selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (VarPat var) = return (localiseId var) -- Note [Localise pattern binders]
selectMatchVar (AsPat var _) = return (unLoc var)
selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
- -- OK, better make up one...
+ -- OK, better make up one...
\end{code}
Note [Localise pattern binders]
@@ -147,7 +141,7 @@ different *unique* by then (the simplifier is good about maintaining
proper scoping), but it's BAD to have two top-level bindings with the
External Name M.a, because that turns into two linker symbols for M.a.
It's quite rare for this to actually *happen* -- the only case I know
-of is tc003 compiled with the 'hpc' way -- but that only makes it
+of is tc003 compiled with the 'hpc' way -- but that only makes it
all the more annoying.
To avoid this, we craftily call 'localiseId' in the desugarer, which
@@ -167,9 +161,9 @@ the desugaring pass.
%************************************************************************
-%* *
-%* type synonym EquationInfo and access functions for its pieces *
-%* *
+%* *
+%* type synonym EquationInfo and access functions for its pieces *
+%* *
%************************************************************************
\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
@@ -234,13 +228,13 @@ wrapBinds [] e = e
wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
-wrapBind new old body -- NB: this function must deal with term
- | new==old = body -- variables, type variables or coercion variables
+wrapBind new old body -- NB: this function must deal with term
+ | new==old = body -- variables, type variables or coercion variables
| otherwise = Let (NonRec new (varToCoreExpr old)) body
seqVar :: Var -> CoreExpr -> CoreExpr
seqVar var body = Case (Var var) var (exprType body)
- [(DEFAULT, [], body)]
+ [(DEFAULT, [], body)]
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
@@ -248,22 +242,22 @@ mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
-- (mkViewMatchResult var' viewExpr var mr) makes the expression
-- let var' = viewExpr var in mr
mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
-mkViewMatchResult var' viewExpr var =
+mkViewMatchResult var' viewExpr var =
adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult var ty
- = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
+ = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
= MatchResult CanFail (\fail -> do body <- body_fn fail
return (mkIfThenElse pred_expr body fail))
-mkCoPrimCaseMatchResult :: Id -- Scrutinee
+mkCoPrimCaseMatchResult :: Id -- Scrutinee
-> Type -- Type of the case
- -> [(Literal, MatchResult)] -- Alternatives
- -> MatchResult -- Literals are all unlifted
+ -> [(Literal, MatchResult)] -- Alternatives
+ -> MatchResult -- Literals are all unlifted
mkCoPrimCaseMatchResult var ty match_alts
= MatchResult CanFail mk_case
where
@@ -271,7 +265,7 @@ mkCoPrimCaseMatchResult var ty match_alts
alts <- mapM (mk_alt fail) sorted_alts
return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
- sorted_alts = sortWith fst match_alts -- Right order for a Case
+ sorted_alts = sortWith fst match_alts -- Right order for a Case
mk_alt fail (lit, MatchResult _ body_fn)
= ASSERT( not (litIsLifted lit) )
do body <- body_fn fail
@@ -282,13 +276,13 @@ data CaseAlt a = MkCaseAlt{ alt_pat :: a,
alt_wrapper :: HsWrapper,
alt_result :: MatchResult }
-mkCoAlgCaseMatchResult
+mkCoAlgCaseMatchResult
:: DynFlags
-> Id -- Scrutinee
-> Type -- Type of exp
-> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts)
-> MatchResult
-mkCoAlgCaseMatchResult dflags var ty match_alts
+mkCoAlgCaseMatchResult dflags var ty match_alts
| isNewtype -- Newtype case; use a let
= ASSERT( null (tail match_alts) && null (tail arg_ids1) )
mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
@@ -300,36 +294,36 @@ mkCoAlgCaseMatchResult dflags var ty match_alts
where
isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))
- -- [Interesting: because of GADTs, we can't rely on the type of
- -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
+ -- [Interesting: because of GADTs, we can't rely on the type of
+ -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }
= ASSERT( notNull match_alts ) head match_alts
-- Stuff for newtype
arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
var_ty = idType var
- (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
- -- (not that splitTyConApp does, these days)
+ (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
+ -- (not that splitTyConApp does, these days)
newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
--- Stuff for parallel arrays
--
- -- Concerning `isPArrFakeAlts':
- --
- -- * it is *not* sufficient to just check the type of the type
- -- constructor, as we have to be careful not to confuse the real
- -- representation of parallel arrays with the fake constructors;
- -- moreover, a list of alternatives must not mix fake and real
- -- constructors (this is checked earlier on)
- --
- -- FIXME: We actually go through the whole list and make sure that
- -- either all or none of the constructors are fake parallel
- -- array constructors. This is to spot equations that mix fake
- -- constructors with the real representation defined in
- -- `PrelPArr'. It would be nicer to spot this situation
- -- earlier and raise a proper error message, but it can really
- -- only happen in `PrelPArr' anyway.
- --
+ -- Concerning `isPArrFakeAlts':
+ --
+ -- * it is *not* sufficient to just check the type of the type
+ -- constructor, as we have to be careful not to confuse the real
+ -- representation of parallel arrays with the fake constructors;
+ -- moreover, a list of alternatives must not mix fake and real
+ -- constructors (this is checked earlier on)
+ --
+ -- FIXME: We actually go through the whole list and make sure that
+ -- either all or none of the constructors are fake parallel
+ -- array constructors. This is to spot equations that mix fake
+ -- constructors with the real representation defined in
+ -- `PrelPArr'. It would be nicer to spot this situation
+ -- earlier and raise a proper error message, but it can really
+ -- only happen in `PrelPArr' anyway.
+ --
isPArrFakeAlts :: [CaseAlt DataCon] -> Bool
isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt)
@@ -454,16 +448,16 @@ mkPArrCase dflags var ty sorted_alts fail = do
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Desugarer's versions of some Core functions}
-%* *
+%* *
%************************************************************************
\begin{code}
-mkErrorAppDs :: Id -- The error function
- -> Type -- Type to which it should be applied
- -> SDoc -- The error message string to pass
- -> DsM CoreExpr
+mkErrorAppDs :: Id -- The error function
+ -> Type -- Type to which it should be applied
+ -> SDoc -- The error message string to pass
+ -> DsM CoreExpr
mkErrorAppDs err_id ty msg = do
src_loc <- getSrcSpanDs
@@ -481,13 +475,13 @@ Note [Desugaring seq (1)] cf Trac #1031
~~~~~~~~~~~~~~~~~~~~~~~~~
f x y = x `seq` (y `seq` (# x,y #))
-The [CoreSyn let/app invariant] means that, other things being equal, because
+The [CoreSyn let/app invariant] means that, other things being equal, because
the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
-But that is bad for two reasons:
- (a) we now evaluate y before x, and
+But that is bad for two reasons:
+ (a) we now evaluate y before x, and
(b) we can't bind v to an unboxed pair
Seq is very, very special! So we recognise it right here, and desugar to
@@ -531,15 +525,15 @@ So we desugar our example to:
And now all is well.
The reason it's a hack is because if you define mySeq=seq, the hack
-won't work on mySeq.
+won't work on mySeq.
Note [Desugaring seq (3)] cf Trac #2409
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The isLocalId ensures that we don't turn
+The isLocalId ensures that we don't turn
True `seq` e
into
case True of True { ... }
-which stupidly tries to bind the datacon 'True'.
+which stupidly tries to bind the datacon 'True'.
\begin{code}
mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr
@@ -551,7 +545,7 @@ mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]
_ -> mkWildValBinder ty1
-mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore
+mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore
mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
@@ -559,9 +553,9 @@ mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
%************************************************************************
-%* *
+%* *
\subsection[mkSelectorBind]{Make a selector bind}
-%* *
+%* *
%************************************************************************
This is used in various places to do with lazy patterns.
@@ -593,12 +587,12 @@ OR (B) t = case e of p -> (x,y)
x = case t of (x,_) -> x
y = case t of (_,y) -> y
-We do (A) when
+We do (A) when
* Matching the pattern is cheap so we don't mind
- doing it twice.
+ doing it twice.
* Or if the pattern binds only one variable (so we'll only
match once)
- * AND the pattern can't fail (else we tiresomely get two inexhaustive
+ * AND the pattern can't fail (else we tiresomely get two inexhaustive
pattern warning messages)
Otherwise we do (B). Really (A) is just an optimisation for very common
@@ -609,8 +603,8 @@ cases like
\begin{code}
mkSelectorBinds :: [Maybe (Tickish Id)] -- ticks to add, possibly
-> LPat Id -- The pattern
- -> CoreExpr -- Expression to which the pattern is bound
- -> DsM [(Id,CoreExpr)]
+ -> CoreExpr -- Expression to which the pattern is bound
+ -> DsM [(Id,CoreExpr)]
mkSelectorBinds ticks (L _ (VarPat v)) val_expr
= return [(v, case ticks of
@@ -618,7 +612,7 @@ mkSelectorBinds ticks (L _ (VarPat v)) val_expr
_ -> val_expr)]
mkSelectorBinds ticks pat val_expr
- | null binders
+ | null binders
= return []
| isSingleton binders || is_simple_lpat pat
@@ -626,7 +620,7 @@ mkSelectorBinds ticks pat val_expr
= do { val_var <- newSysLocalDs (hsLPatType pat)
-- Make up 'v' in Note [mkSelectorBinds]
-- NB: give it the type of *pattern* p, not the type of the *rhs* e.
- -- This does not matter after desugaring, but there's a subtle
+ -- This does not matter after desugaring, but there's a subtle
-- issue with implicit parameters. Consider
-- (x,y) = ?i
-- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
@@ -701,8 +695,8 @@ which is whey they are not in HsUtils.
mkLHsPatTup :: [LPat Id] -> LPat Id
mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats = L (getLoc (head lpats)) $
- mkVanillaTuplePat lpats Boxed
+mkLHsPatTup lpats = L (getLoc (head lpats)) $
+ mkVanillaTuplePat lpats Boxed
mkLHsVarPatTup :: [Id] -> LPat Id
mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
@@ -727,21 +721,21 @@ mkBigLHsPatTup = mkChunkified mkLHsPatTup
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
-%* *
+%* *
%************************************************************************
Generally, we handle pattern matching failure like this: let-bind a
fail-variable, and use that variable if the thing fails:
\begin{verbatim}
- let fail.33 = error "Help"
- in
- case x of
- p1 -> ...
- p2 -> fail.33
- p3 -> fail.33
- p4 -> ...
+ let fail.33 = error "Help"
+ in
+ case x of
+ p1 -> ...
+ p2 -> fail.33
+ p3 -> fail.33
+ p4 -> ...
\end{verbatim}
Then
\begin{itemize}
@@ -760,31 +754,31 @@ There's a problem when the result of the case expression is of
unboxed type. Then the type of @fail.33@ is unboxed too, and
there is every chance that someone will change the let into a case:
\begin{verbatim}
- case error "Help" of
- fail.33 -> case ....
+ case error "Help" of
+ fail.33 -> case ....
\end{verbatim}
which is of course utterly wrong. Rather than drop the condition that
only boxed types can be let-bound, we just turn the fail into a function
for the primitive case:
\begin{verbatim}
- let fail.33 :: Void -> Int#
- fail.33 = \_ -> error "Help"
- in
- case x of
- p1 -> ...
- p2 -> fail.33 void
- p3 -> fail.33 void
- p4 -> ...
+ let fail.33 :: Void -> Int#
+ fail.33 = \_ -> error "Help"
+ in
+ case x of
+ p1 -> ...
+ p2 -> fail.33 void
+ p3 -> fail.33 void
+ p4 -> ...
\end{verbatim}
Now @fail.33@ is a function, so it can be let-bound.
\begin{code}
-mkFailurePair :: CoreExpr -- Result type of the whole case expression
- -> DsM (CoreBind, -- Binds the newly-created fail variable
- -- to \ _ -> expression
- CoreExpr) -- Fail variable applied to realWorld#
+mkFailurePair :: CoreExpr -- Result type of the whole case expression
+ -> DsM (CoreBind, -- Binds the newly-created fail variable
+ -- to \ _ -> expression
+ CoreExpr) -- Fail variable applied to realWorld#
-- See Note [Failure thunks and CPR]
mkFailurePair expr
= do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)
@@ -802,10 +796,10 @@ When we make a failure point we ensure that it
does not look like a thunk. Example:
let fail = \rw -> error "urk"
- in case x of
+ in case x of
[] -> fail realWorld#
(y:ys) -> case ys of
- [] -> fail realWorld#
+ [] -> fail realWorld#
(z:zs) -> (y,z)
Reason: we know that a failure point is always a "join point" and is
@@ -821,7 +815,7 @@ mkOptTickBox (Just tickish) e = Tick tickish e
mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox ixT ixF e = do
- uq <- newUnique
+ uq <- newUnique
this_mod <- getModule
let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
let
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 8e581f66e2..611d48e456 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -7,18 +7,12 @@ Pattern-matching constructors
\begin{code}
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
module MatchCon ( matchConFamily, matchPatSyn ) where
#include "HsVersions.h"
-import {-# SOURCE #-} Match ( match )
+import {-# SOURCE #-} Match ( match )
import HsSyn
import DsBinds
@@ -92,8 +86,8 @@ have-we-used-all-the-constructors? question; the local function
\begin{code}
matchConFamily :: [Id]
-> Type
- -> [[EquationInfo]]
- -> DsM MatchResult
+ -> [[EquationInfo]]
+ -> DsM MatchResult
-- Each group of eqns is for a single constructor
matchConFamily (var:vars) ty groups
= do dflags <- getDynFlags
@@ -124,17 +118,17 @@ matchOneConLike :: [Id]
-> Type
-> [EquationInfo]
-> DsM (CaseAlt ConLike)
-matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
- = do { arg_vars <- selectConMatchVars val_arg_tys args1
- -- Use the first equation as a source of
- -- suggestions for the new variables
+matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
+ = do { arg_vars <- selectConMatchVars val_arg_tys args1
+ -- Use the first equation as a source of
+ -- suggestions for the new variables
- -- Divide into sub-groups; see Note [Record patterns]
+ -- Divide into sub-groups; see Note [Record patterns]
; let groups :: [[(ConArgPats, EquationInfo)]]
- groups = runs compatible_pats [ (pat_args (firstPat eqn), eqn)
- | eqn <- eqn1:eqns ]
+ groups = runs compatible_pats [ (pat_args (firstPat eqn), eqn)
+ | eqn <- eqn1:eqns ]
- ; match_results <- mapM (match_group arg_vars) groups
+ ; match_results <- mapM (match_group arg_vars) groups
; return $ MkCaseAlt{ alt_pat = con1,
alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,
@@ -142,19 +136,19 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
alt_result = foldr1 combineMatchResults match_results } }
where
ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,
- pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
- = firstPat eqn1
+ pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
+ = firstPat eqn1
fields1 = case con1 of
- RealDataCon dcon1 -> dataConFieldLabels dcon1
- PatSynCon{} -> []
+ RealDataCon dcon1 -> dataConFieldLabels dcon1
+ PatSynCon{} -> []
val_arg_tys = case con1 of
RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 inst_tys
PatSynCon psyn1 -> patSynInstArgTys psyn1 inst_tys
inst_tys = ASSERT( tvs1 `equalLength` ex_tvs )
arg_tys ++ mkTyVarTys tvs1
- -- dataConInstOrigArgTys takes the univ and existential tyvars
- -- and returns the types of the *value* args, which is what we want
+ -- dataConInstOrigArgTys takes the univ and existential tyvars
+ -- and returns the types of the *value* args, which is what we want
ex_tvs = case con1 of
RealDataCon dcon1 -> dataConExTyVars dcon1
@@ -165,13 +159,13 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
match_group arg_vars arg_eqn_prs
= ASSERT( notNull arg_eqn_prs )
do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
- ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
- ; match_result <- match (group_arg_vars ++ vars) ty eqns'
- ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
+ ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
+ ; match_result <- match (group_arg_vars ++ vars) ty eqns'
+ ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
- shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
- pat_binds = bind, pat_args = args
- } : pats }))
+ shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
+ pat_binds = bind, pat_args = args
+ } : pats }))
= do ds_bind <- dsTcEvBinds bind
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
@@ -184,17 +178,17 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
-- Note [Record patterns]
select_arg_vars arg_vars ((arg_pats, _) : _)
| RecCon flds <- arg_pats
- , let rpats = rec_flds flds
+ , let rpats = rec_flds flds
, not (null rpats) -- Treated specially; cf conArgPats
- = ASSERT2( length fields1 == length arg_vars,
+ = ASSERT2( length fields1 == length arg_vars,
ppr con1 $$ ppr fields1 $$ ppr arg_vars )
map lookup_fld rpats
| otherwise
= arg_vars
where
fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
- lookup_fld rpat = lookupNameEnv_NF fld_var_env
- (idName (unLoc (hsRecFieldId rpat)))
+ lookup_fld rpat = lookupNameEnv_NF fld_var_env
+ (idName (unLoc (hsRecFieldId rpat)))
select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
matchOneConLike _ _ [] = panic "matchOneCon []"
@@ -208,9 +202,9 @@ compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2)
compatible_pats _ _ = True -- Prefix or infix con
same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool
-same_fields flds1 flds2
+same_fields flds1 flds2
= all2 (\f1 f2 -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
- (rec_flds flds1) (rec_flds flds2)
+ (rec_flds flds1) (rec_flds flds2)
-----------------
@@ -219,38 +213,38 @@ selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDs arg_tys
selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps)
selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]
-conArgPats :: [Type] -- Instantiated argument types
- -- Used only to fill in the types of WildPats, which
- -- are probably never looked at anyway
- -> ConArgPats
- -> [Pat Id]
+conArgPats :: [Type] -- Instantiated argument types
+ -- Used only to fill in the types of WildPats, which
+ -- are probably never looked at anyway
+ -> ConArgPats
+ -> [Pat Id]
conArgPats _arg_tys (PrefixCon ps) = map unLoc ps
conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
| null rpats = map WildPat arg_tys
- -- Important special case for C {}, which can be used for a
- -- datacon that isn't declared to have fields at all
+ -- Important special case for C {}, which can be used for a
+ -- datacon that isn't declared to have fields at all
| otherwise = map (unLoc . hsRecFieldArg) rpats
\end{code}
Note [Record patterns]
~~~~~~~~~~~~~~~~~~~~~~
-Consider
- data T = T { x,y,z :: Bool }
+Consider
+ data T = T { x,y,z :: Bool }
- f (T { y=True, x=False }) = ...
+ f (T { y=True, x=False }) = ...
We must match the patterns IN THE ORDER GIVEN, thus for the first
-one we match y=True before x=False. See Trac #246; or imagine
+one we match y=True before x=False. See Trac #246; or imagine
matching against (T { y=False, x=undefined }): should fail without
-touching the undefined.
+touching the undefined.
Now consider:
- f (T { y=True, x=False }) = ...
- f (T { x=True, y= False}) = ...
+ f (T { y=True, x=False }) = ...
+ f (T { x=True, y= False}) = ...
-In the first we must test y first; in the second we must test x
+In the first we must test y first; in the second we must test x
first. So we must divide even the equations for a single constructor
T into sub-goups, based on whether they match the same field in the
same order. That's what the (runs compatible_pats) grouping.
@@ -264,31 +258,31 @@ Hence the (null rpats) checks here and there.
Note [Existentials in shift_con_pat]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
- data T = forall a. Ord a => T a (a->Int)
+ data T = forall a. Ord a => T a (a->Int)
- f (T x f) True = ...expr1...
- f (T y g) False = ...expr2..
+ f (T x f) True = ...expr1...
+ f (T y g) False = ...expr2..
When we put in the tyvars etc we get
- f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1...
- f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2...
+ f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1...
+ f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2...
After desugaring etc we'll get a single case:
- f = \t::T b::Bool ->
- case t of
- T a (d::Ord a) (x::a) (f::a->Int)) ->
- case b of
- True -> ...expr1...
- False -> ...expr2...
+ f = \t::T b::Bool ->
+ case t of
+ T a (d::Ord a) (x::a) (f::a->Int)) ->
+ case b of
+ True -> ...expr1...
+ False -> ...expr2...
*** We have to substitute [a/b, d/e] in expr2! **
Hence
- False -> ....((/\b\(e:Ord b).expr2) a d)....
+ False -> ....((/\b\(e:Ord b).expr2) a d)....
-Originally I tried to use
- (\b -> let e = d in expr2) a
+Originally I tried to use
+ (\b -> let e = d in expr2) a
to do this substitution. While this is "correct" in a way, it fails
-Lint, because e::Ord b but d::Ord a.
+Lint, because e::Ord b but d::Ord a.
View Lorry Controller Status