Commit d551dbfe authored by simonpj's avatar simonpj

[project @ 2005-04-04 11:55:11 by simonpj]

This commit combines three overlapping things:

1.  Make rebindable syntax work for do-notation. The idea
    here is that, in particular, (>>=) can have a type that
    has class constraints on its argument types, e.g.
       (>>=) :: (Foo m, Baz a) => m a -> (a -> m b) -> m b
    The consequence is that a BindStmt and ExprStmt must have
    individual evidence attached -- previously it was one
    batch of evidence for the entire Do
    
    Sadly, we can't do this for MDo, because we use bind at
    a polymorphic type (to tie the knot), so we still use one
    blob of evidence (now in the HsStmtContext) for MDo.
    
    For arrow syntax, the evidence is in the HsCmd.
    
    For list comprehensions, it's all built-in anyway.
    
    So the evidence on a BindStmt is only used for ordinary
    do-notation.

2.  Tidy up HsSyn.  In particular:

	- Eliminate a few "Out" forms, which we can manage
	without (e.g. 

	- It ought to be the case that the type checker only
	decorates the syntax tree, but doesn't change one
	construct into another.  That wasn't true for NPat,
	LitPat, NPlusKPat, so I've fixed that.

	- Eliminate ResultStmts from Stmt.  They always had
	to be the last Stmt, which led to awkward pattern
	matching in some places; and the benefits didn't seem
	to outweigh the costs.  Now each construct that uses
	[Stmt] has a result expression too (e.g. GRHS).


3.  Make 'deriving( Ix )' generate a binding for unsafeIndex,
    rather than for index.  This is loads more efficient.

    (This item only affects TcGenDeriv, but some of point (2)
    also affects TcGenDeriv, so it has to be in one commit.)
parent cb486104
......@@ -289,6 +289,13 @@ data IdInfo
strictnessInfo :: StrictnessInfo, -- Strictness properties
#endif
workerInfo :: WorkerInfo, -- Pointer to Worker Function
-- Within one module this is irrelevant; the
-- inlining of a worker is handled via the Unfolding
-- WorkerInfo is used *only* to indicate the form of
-- the RHS, so that interface files don't actually
-- need to contain the RHS; it can be derived from
-- the strictness info
unfoldingInfo :: Unfolding, -- Its unfolding
cafInfo :: CafInfo, -- CAF info
lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable
......
......@@ -411,12 +411,19 @@ get_used_lits qs = remove_dups' all_literals
get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]
get_used_lits' [] = []
get_used_lits' (q:qs)
| LitPat lit <- first_pat = lit : get_used_lits qs
| NPatOut lit _ _ <- first_pat = lit : get_used_lits qs
| otherwise = get_used_lits qs
| LitPat lit <- first_pat = lit : get_used_lits qs
| NPat lit _ _ _ <- first_pat = over_lit_lit lit : get_used_lits qs
| otherwise = get_used_lits qs
where
first_pat = firstPatN q
over_lit_lit :: HsOverLit id -> HsLit
-- Get a representative HsLit to stand for the OverLit
-- It doesn't matter which one, because they will only be compared
-- with other HsLits gotten in the same way
over_lit_lit (HsIntegral i _) = HsIntPrim i
over_lit_lit (HsFractional f _) = HsFloatPrim f
get_unused_cons :: [Pat Id] -> [DataCon]
get_unused_cons used_cons = unused_cons
where
......@@ -462,7 +469,7 @@ is_con _ = False
is_lit :: Pat Id -> Bool
is_lit (LitPat _) = True
is_lit (NPatOut _ _ _) = True
is_lit (NPat _ _ _ _) = True
is_lit _ = False
is_var :: Pat Id -> Bool
......@@ -475,10 +482,10 @@ is_var_con con (ConPatOut (L _ id) _ _ _ _ _) | id == con = True
is_var_con con _ = False
is_var_lit :: HsLit -> Pat Id -> Bool
is_var_lit lit (WildPat _) = True
is_var_lit lit (LitPat lit') | lit == lit' = True
is_var_lit lit (NPatOut lit' _ _) | lit == lit' = True
is_var_lit lit _ = False
is_var_lit lit (WildPat _) = True
is_var_lit lit (LitPat lit') = lit == lit'
is_var_lit lit (NPat lit' _ _ _) = lit == over_lit_lit lit'
is_var_lit lit _ = False
\end{code}
The difference beteewn @make_con@ and @make_whole_con@ is that
......@@ -608,19 +615,19 @@ simplify_pat (TuplePat ps boxity)
where
arity = length ps
simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat))
-- unpack string patterns fully, so we can see when they overlap with
-- each other, or even explicit lists of Chars.
simplify_pat pat@(NPatOut (HsString s) _ _) =
simplify_pat pat@(LitPat (HsString s)) =
foldr (\c pat -> mk_simple_con_pat consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy)
(mk_simple_con_pat nilDataCon (PrefixCon []) stringTy) (unpackFS s)
where
mk_char_lit c = noLoc (mk_simple_con_pat charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) charTy)
simplify_pat pat@(NPatOut lit lit_ty hsexpr) = unLoc (tidyNPat lit lit_ty (noLoc pat))
simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat))
simplify_pat pat@(NPat lit mb_neg _ lit_ty) = unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat))
simplify_pat (NPlusKPatOut id hslit hsexpr1 hsexpr2)
simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2)
= WildPat (idType (unLoc id))
simplify_pat (DictPat dicts methods)
......
......@@ -13,7 +13,7 @@ import DsUtils ( mkErrorAppDs,
mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL,
mkTupleCase, mkBigCoreTup, mkTupleType,
mkTupleExpr, mkTupleSelector,
dsReboundNames, lookupReboundName )
dsSyntaxTable, lookupEvidence )
import DsMonad
import HsSyn
......@@ -57,17 +57,17 @@ data DsCmdEnv = DsCmdEnv {
arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
}
mkCmdEnv :: ReboundNames Id -> DsM DsCmdEnv
mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv
mkCmdEnv ids
= dsReboundNames ids `thenDs` \ (meth_binds, ds_meths) ->
= dsSyntaxTable ids `thenDs` \ (meth_binds, ds_meths) ->
return $ DsCmdEnv {
meth_binds = meth_binds,
arr_id = lookupReboundName ds_meths arrAName,
compose_id = lookupReboundName ds_meths composeAName,
first_id = lookupReboundName ds_meths firstAName,
app_id = lookupReboundName ds_meths appAName,
choice_id = lookupReboundName ds_meths choiceAName,
loop_id = lookupReboundName ds_meths loopAName
arr_id = Var (lookupEvidence ds_meths arrAName),
compose_id = Var (lookupEvidence ds_meths composeAName),
first_id = Var (lookupEvidence ds_meths firstAName),
app_id = Var (lookupEvidence ds_meths appAName),
choice_id = Var (lookupEvidence ds_meths choiceAName),
loop_id = Var (lookupEvidence ds_meths loopAName)
}
bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
......@@ -388,7 +388,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg)
-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
dsCmd ids local_vars env_ids stack res_ty
(HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ ))] _))
(HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
= let
pat_vars = mkVarSet (collectPatsBinders pats)
local_vars' = local_vars `unionVarSet` pat_vars
......@@ -575,8 +575,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
core_body,
exprFreeVars core_binds `intersectVarSet` local_vars)
dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _)
= dsCmdDo ids local_vars env_ids res_ty stmts
dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
= dsCmdDo ids local_vars env_ids res_ty stmts body
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
-- A | xs |- ci :: [tsi] ti
......@@ -650,7 +650,8 @@ dsCmdDo :: DsCmdEnv -- arrow combinators
-- This is typically fed back,
-- so don't pull on it too early
-> Type -- return type of the statement
-> [LStmt Id] -- statements to desugar
-> [LStmt Id] -- statements to desugar
-> LHsExpr Id -- body
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
......@@ -658,16 +659,16 @@ dsCmdDo :: DsCmdEnv -- arrow combinators
-- --------------------------
-- A | xs |- do { c } :: [] t
dsCmdDo ids local_vars env_ids res_ty [L _ (ResultStmt cmd)]
= dsLCmd ids local_vars env_ids [] res_ty cmd
dsCmdDo ids local_vars env_ids res_ty [] body
= dsLCmd ids local_vars env_ids [] res_ty body
dsCmdDo ids local_vars env_ids res_ty (stmt:stmts)
dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body
= let
bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
local_vars' = local_vars `unionVarSet` bound_vars
in
fixDs (\ ~(_,_,env_ids') ->
dsCmdDo ids local_vars' env_ids' res_ty stmts
dsCmdDo ids local_vars' env_ids' res_ty stmts body
`thenDs` \ (core_stmts, fv_stmts) ->
returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
`thenDs` \ (core_stmts, fv_stmts, env_ids') ->
......@@ -708,7 +709,7 @@ dsCmdStmt
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- arr snd >>> ss
dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty)
dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty)
= dsfixCmd ids local_vars [] c_ty cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
matchEnvStack env_ids []
......@@ -740,7 +741,7 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty)
-- It would be simpler and more consistent to do this using second,
-- but that's likely to be defined in terms of first.
dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd)
dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
= dsfixCmd ids local_vars [] (hsPatType pat) cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
let
......@@ -820,8 +821,8 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
-- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss)
= let
dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss binds)
= let -- ****** binds not desugared; ROSS PLEASE FIX ********
env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
env2_ids = varSetElems env2_id_set
env2_ty = mkTupleType env2_ids
......@@ -885,7 +886,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
-- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))
mappM dsLExpr rhss `thenDs` \ core_rhss ->
mappM dsExpr rhss `thenDs` \ core_rhss ->
let
later_tuple = mkTupleExpr later_ids
later_ty = mkTupleType later_ids
......@@ -1011,10 +1012,9 @@ leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
mkVarSet (map unLoc (collectGroupBinders binds))
in
[(expr,
mkVarSet (map unLoc (collectStmtsBinders stmts))
mkVarSet (map unLoc (collectLStmtsBinders stmts))
`unionVarSet` defined_vars)
| L _ (GRHS stmts) <- grhss,
let L _ (ResultStmt expr) = last stmts]
| L _ (GRHS stmts expr) <- grhss]
\end{code}
Replace the leaf commands in a match
......@@ -1037,8 +1037,8 @@ replaceLeavesGRHS
-> LGRHS Id -- rhss of a case command
-> ([LHsExpr Id],-- remaining leaf expressions
LGRHS Id) -- updated GRHS
replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts))
= (leaves, L loc (GRHS (init stmts ++ [L (getLoc leaf) (ResultStmt leaf)])))
replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs))
= (leaves, L loc (GRHS stmts leaf))
\end{code}
Balanced fold of a non-empty list.
......
This diff is collapsed.
......@@ -12,7 +12,7 @@ import {-# SOURCE #-} DsExpr ( dsLExpr, dsLet )
import {-# SOURCE #-} Match ( matchSinglePat )
import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..),
HsMatchContext(..), Pat(..) )
LHsExpr, HsMatchContext(..), Pat(..) )
import CoreSyn ( CoreExpr )
import Var ( Id )
import Type ( Type )
......@@ -64,8 +64,9 @@ dsGRHSs kind pats (GRHSs grhss binds) rhs_ty
in
returnDs match_result2
dsGRHS kind pats rhs_ty (L loc (GRHS guard))
= matchGuard (map unLoc guard) (DsMatchContext kind pats loc) rhs_ty
dsGRHS kind pats rhs_ty (L loc (GRHS guards rhs))
= matchGuard (map unLoc guards) (DsMatchContext kind pats loc)
rhs rhs_ty
\end{code}
......@@ -78,41 +79,42 @@ dsGRHS kind pats rhs_ty (L loc (GRHS guard))
\begin{code}
matchGuard :: [Stmt Id] -- Guard
-> DsMatchContext -- Context
-> LHsExpr Id -- RHS
-> Type -- Type of RHS of guard
-> DsM MatchResult
-- See comments with HsExpr.Stmt re what an ExprStmt means
-- Here we must be in a guard context (not do-expression, nor list-comp)
matchGuard [ResultStmt expr] ctx rhs_ty
= do { core_expr <- dsLExpr expr
; return (cantFailMatchResult core_expr) }
matchGuard [] ctx rhs rhs_ty
= do { core_rhs <- dsLExpr rhs
; return (cantFailMatchResult core_rhs) }
-- ExprStmts must be guards
-- Turn an "otherwise" guard is a no-op
matchGuard (ExprStmt (L _ (HsVar v)) _ : stmts) ctx rhs_ty
matchGuard (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty
| v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
-- trueDataConId doesn't have the same
-- unique as trueDataCon
= matchGuard stmts ctx rhs_ty
= matchGuard stmts ctx rhs rhs_ty
matchGuard (ExprStmt expr _ : stmts) ctx rhs_ty
= matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
dsLExpr expr `thenDs` \ pred_expr ->
matchGuard (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
= matchGuard stmts ctx rhs rhs_ty `thenDs` \ match_result ->
dsLExpr expr `thenDs` \ pred_expr ->
returnDs (mkGuardedMatchResult pred_expr match_result)
matchGuard (LetStmt binds : stmts) ctx rhs_ty
= matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
matchGuard (LetStmt binds : stmts) ctx rhs rhs_ty
= matchGuard stmts ctx rhs rhs_ty `thenDs` \ match_result ->
returnDs (adjustMatchResultDs (dsLet binds) match_result)
-- NB the dsLet occurs inside the match_result
-- Reason: dsLet takes the body expression as its argument
-- so we can't desugar the bindings without the
-- body expression in hand
matchGuard (BindStmt pat bind_rhs : stmts) ctx rhs_ty
= matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
dsLExpr bind_rhs `thenDs` \ core_rhs ->
matchGuard (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
= matchGuard stmts ctx rhs rhs_ty `thenDs` \ match_result ->
dsLExpr bind_rhs `thenDs` \ core_rhs ->
matchSinglePat core_rhs ctx pat rhs_ty match_result
\end{code}
......
This diff is collapsed.
......@@ -512,13 +512,17 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
; z <- repLetE ds e2
; wrapGenSyns ss z }
-- FIXME: I haven't got the types here right yet
repE (HsDo DoExpr sts _ ty)
repE (HsDo DoExpr sts body ty)
= do { (ss,zs) <- repLSts sts;
e <- repDoE (nonEmptyCoreList zs);
body' <- repLE body;
ret <- repNoBindSt body';
e <- repDoE (nonEmptyCoreList (zs ++ [ret]));
wrapGenSyns ss e }
repE (HsDo ListComp sts _ ty)
repE (HsDo ListComp sts body ty)
= do { (ss,zs) <- repLSts sts;
e <- repComp (nonEmptyCoreList zs);
body' <- repLE body;
ret <- repNoBindSt body';
e <- repComp (nonEmptyCoreList (zs ++ [ret]));
wrapGenSyns ss e }
repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs }
......@@ -527,11 +531,11 @@ repE (ExplicitPArr ty es) =
repE (ExplicitTuple es boxed)
| isBoxed boxed = do { xs <- repLEs es; repTup xs }
| otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
repE (RecordCon c flds)
repE (RecordCon c _ flds)
= do { x <- lookupLOcc c;
fs <- repFields flds;
repRecCon x fs }
repE (RecordUpd e flds)
repE (RecordUpd e flds _ _)
= do { x <- repLE e;
fs <- repFields flds;
repRecUpd x fs }
......@@ -592,7 +596,7 @@ repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
; wrapGenSyns (ss1++ss2) clause }}}
repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
repGuards [L _ (GRHS [L _ (ResultStmt e)])]
repGuards [L _ (GRHS [] e)]
= do {a <- repLE e; repNormal a }
repGuards other
= do { zs <- mapM process other;
......@@ -601,14 +605,13 @@ repGuards other
wrapGenSyns (concat xs) gd }
where
process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
process (L _ (GRHS [])) = panic "No guards in guarded body"
process (L _ (GRHS [L _ (ExprStmt e1 ty),
L _ (ResultStmt e2)]))
process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
= do { x <- repLNormalGE e1 e2;
return ([], x) }
process (L _ (GRHS ss))
process (L _ (GRHS ss rhs))
= do (gs, ss') <- repLSts ss
g <- repPatGE (nonEmptyCoreList ss')
rhs' <- repLE rhs
g <- repPatGE (nonEmptyCoreList ss') rhs'
return (gs, g)
repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
......@@ -648,11 +651,7 @@ repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
repLSts stmts = repSts (map unLoc stmts)
repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
repSts [ResultStmt e] =
do { a <- repLE e
; e1 <- repNoBindSt a
; return ([], [e1]) }
repSts (BindStmt p e : ss) =
repSts (BindStmt p e _ _ : ss) =
do { e2 <- repLE e
; ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
......@@ -665,7 +664,7 @@ repSts (LetStmt bs : ss) =
; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss)
; return (ss1++ss2, z : zs) }
repSts (ExprStmt e ty : ss) =
repSts (ExprStmt e _ _ : ss) =
do { e2 <- repLE e
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
......@@ -774,7 +773,7 @@ rep_bind (L loc (VarBind v e))
-- (\ p1 .. pn -> exp) by causing an error.
repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [])))
repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [])] [])))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
......@@ -821,8 +820,8 @@ repP (ConPatIn dc details)
p2' <- repLP p2;
repPinfix p1' con_str p2' }
}
repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
repP (SigPatIn p t) = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
repP other = panic "Exotic pattern inside meta brackets"
......@@ -1107,8 +1106,8 @@ repLNormalGE g e = do g' <- repLE g
repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
repPatGE :: Core [TH.StmtQ] -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
repPatGE (MkC ss) = rep2 patGEName [ss]
repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
repPatGE (MkC ss) = rep2 patGName [ss]
------------- Stmts -------------------
repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
......@@ -1255,7 +1254,7 @@ mk_integer i = do integer_ty <- lookupType integerTyConName
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
repOverloadedLiteral :: HsOverLit -> DsM (Core TH.Lit)
repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit }
repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
-- The type Rational will be in the environment, becuase
......
......@@ -16,8 +16,8 @@ module DsUtils (
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
mkCoLetMatchResult,
mkGuardedMatchResult,
mkCoLetMatchResult, mkGuardedMatchResult,
matchCanFail,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
wrapBind, wrapBinds,
......@@ -29,7 +29,7 @@ module DsUtils (
mkTupleType, mkTupleCase, mkBigCoreTup,
mkCoreTup, mkCoreTupTy,
dsReboundNames, lookupReboundName,
dsSyntaxTable, lookupEvidence,
selectSimpleMatchVarL, selectMatchVars
) where
......@@ -85,11 +85,11 @@ import FastString
%************************************************************************
\begin{code}
dsReboundNames :: ReboundNames Id
dsSyntaxTable :: SyntaxTable Id
-> DsM ([CoreBind], -- Auxiliary bindings
[(Name,Id)]) -- Maps the standard name to its value
dsReboundNames rebound_ids
dsSyntaxTable rebound_ids
= mapAndUnzipDs mk_bind rebound_ids `thenDs` \ (binds_s, prs) ->
return (concat binds_s, prs)
where
......@@ -101,11 +101,11 @@ dsReboundNames rebound_ids
newSysLocalDs (exprType rhs) `thenDs` \ id ->
return ([NonRec id rhs], (std_name, id))
lookupReboundName :: [(Name,Id)] -> Name -> CoreExpr
lookupReboundName prs std_name
= Var (assocDefault (mk_panic std_name) prs std_name)
lookupEvidence :: [(Name, Id)] -> Name -> Id
lookupEvidence prs std_name
= assocDefault (mk_panic std_name) prs std_name
where
mk_panic std_name = pprPanic "dsReboundNames" (ptext SLIT("Not found:") <+> ppr std_name)
mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
\end{code}
......@@ -198,6 +198,10 @@ shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
Functions on MatchResults
\begin{code}
matchCanFail :: MatchResult -> Bool
matchCanFail (MatchResult CanFail _) = True
matchCanFail (MatchResult CantFail _) = False
alwaysFailMatchResult :: MatchResult
alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
......@@ -407,6 +411,7 @@ mkErrorAppDs err_id ty msg
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
core_msg = Lit (mkStringLit full_msg)
-- mkStringLit returns a result of type String#
in
returnDs (mkApps (Var err_id) [Type ty, core_msg])
\end{code}
......
......@@ -284,19 +284,19 @@ match vars@(v:_) ty eqns_info
match_block eqns
= case firstPat (head eqns) of
WildPat {} -> matchVariables vars ty eqns
ConPatOut {} -> matchConFamily vars ty eqns
NPlusKPatOut {} -> matchNPlusKPats vars ty eqns
NPatOut {} -> matchNPats vars ty eqns
LitPat {} -> matchLiterals vars ty eqns
WildPat {} -> matchVariables vars ty eqns
ConPatOut {} -> matchConFamily vars ty eqns
NPlusKPat {} -> matchNPlusKPats vars ty eqns
NPat {} -> matchNPats vars ty eqns
LitPat {} -> matchLiterals vars ty eqns
-- After tidying, there are only five kinds of patterns
samePatFamily (WildPat {}) (WildPat {}) = True
samePatFamily (ConPatOut {}) (ConPatOut {}) = True
samePatFamily (NPlusKPatOut {}) (NPlusKPatOut {}) = True
samePatFamily (NPatOut {}) (NPatOut {}) = True
samePatFamily (LitPat {}) (LitPat {}) = True
samePatFamily _ _ = False
samePatFamily (WildPat {}) (WildPat {}) = True
samePatFamily (ConPatOut {}) (ConPatOut {}) = True
samePatFamily (NPlusKPat {}) (NPlusKPat {}) = True
samePatFamily (NPat {}) (NPat {}) = True
samePatFamily (LitPat {}) (LitPat {}) = True
samePatFamily _ _ = False
matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Real true variables, just like in matchVar, SLPJ p 94
......@@ -474,8 +474,8 @@ tidy1 v wrap pat@(LitPat lit)
= returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat)))
-- NPats: we *might* be able to replace these w/ a simpler form
tidy1 v wrap pat@(NPatOut lit lit_ty _)
= returnDs (wrap, unLoc (tidyNPat lit lit_ty (noLoc pat)))
tidy1 v wrap pat@(NPat lit mb_neg _ lit_ty)
= returnDs (wrap, unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat)))
-- and everything else goes through unchanged...
......@@ -700,33 +700,35 @@ matchSimply :: CoreExpr -- Scrutinee
-> CoreExpr -- Return this if it doesn't
-> DsM CoreExpr
matchSimply scrut kind pat result_expr fail_expr
= getSrcSpanDs `thenDs` \ locn ->
let
ctx = DsMatchContext kind [unLoc pat] locn
matchSimply scrut hs_ctx pat result_expr fail_expr
= let
match_result = cantFailMatchResult result_expr
rhs_ty = exprType fail_expr
-- Use exprType of fail_expr, because won't refine in the case of failure!
in
matchSinglePat scrut ctx pat rhs_ty match_result `thenDs` \ match_result' ->
matchSinglePat scrut hs_ctx pat rhs_ty match_result `thenDs` \ match_result' ->
extractMatchResult match_result' fail_expr
matchSinglePat :: CoreExpr -> DsMatchContext -> LPat Id
matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
-> Type -> MatchResult -> DsM MatchResult
matchSinglePat (Var var) ctx pat ty match_result
= getDOptsDs `thenDs` \ dflags ->
matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result
= getDOptsDs `thenDs` \ dflags ->
getSrcSpanDs `thenDs` \ locn ->
let
match_fn dflags
| dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
| otherwise = match
where
ds_ctx = DsMatchContext hs_ctx [pat] locn
in
match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper,
eqn_pats = [unLoc pat],
eqn_pats = [pat],
eqn_rhs = match_result }]
where
match_fn dflags
| dopt Opt_WarnSimplePatterns dflags = matchCheck ctx
| otherwise = match
matchSinglePat scrut ctx pat ty match_result
matchSinglePat scrut hs_ctx pat ty match_result
= selectSimpleMatchVarL pat `thenDs` \ var ->
matchSinglePat (Var var) ctx pat ty match_result `thenDs` \ match_result' ->
matchSinglePat (Var var) hs_ctx pat ty match_result `thenDs` \ match_result' ->
returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
\end{code}
......@@ -10,7 +10,7 @@ module MatchCon ( matchConFamily ) where
import {-# SOURCE #-} Match ( match )
import HsSyn ( Pat(..), HsConDetails(..), isEmptyLHsBinds )
import HsSyn ( Pat(..), HsConDetails(..) )
import DsBinds ( dsHsNestedBinds )
import DataCon ( isVanillaDataCon, dataConTyVars, dataConOrigArgTys )
import TcType ( tcTyConAppArgs )
......
This diff is collapsed.
......@@ -196,23 +196,32 @@ cvt (LitE l)
cvt (AppE x y) = HsApp (cvtl x) (cvtl y)
cvt (LamE ps e) = HsLam (mkMatchGroup [mkSimpleMatch (map cvtlp ps) (cvtl e)])
cvt (TupE [e]) = cvt e
cvt (TupE es) = ExplicitTuple(map cvtl es) Boxed
cvt (TupE [e]) = cvt e
cvt (TupE es) = ExplicitTuple(map cvtl es) Boxed
cvt (CondE x y z) = HsIf (cvtl x) (cvtl y) (cvtl z)
cvt (LetE ds e) = HsLet (cvtdecs ds) (cvtl e)
cvt (LetE ds e) = HsLet (cvtdecs ds) (cvtl e)
cvt (CaseE e ms) = HsCase (cvtl e) (mkMatchGroup (map cvtm ms))
cvt (DoE ss) = HsDo DoExpr (cvtstmts ss) [] void
cvt (CompE ss) = HsDo ListComp (cvtstmts ss) [] void
cvt (ArithSeqE dd) = ArithSeqIn (cvtdd dd)
cvt (ListE xs) = ExplicitList void (map cvtl xs)
cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
cvt (ArithSeqE dd) = ArithSeq noPostTcExpr (cvtdd dd)
cvt (ListE xs) = ExplicitList void (map cvtl xs)
cvt (InfixE (Just x) s (Just y))
= HsPar (noLoc $ OpApp (cvtl x) (cvtl s) undefined (cvtl y))
cvt (InfixE Nothing s (Just y)) = SectionR (cvtl s) (cvtl y)
cvt (InfixE (Just x) s Nothing ) = SectionL (cvtl x) (cvtl s)
cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
cvt (SigE e t) = ExprWithTySig (cvtl e) (cvtType t)
cvt (RecConE c flds) = RecordCon (noLoc (cName c)) (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds)
cvt (RecConE c flds) = RecordCon (noLoc (cName c)) noPostTcExpr
(map (\(x,y) -> (noLoc (vName x), cvtl y)) flds)
cvt (RecUpdE e flds) = RecordUpd (cvtl e) (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds)
placeHolderType placeHolderType
cvtHsDo do_or_lc stmts
= HsDo do_or_ld (init stmts') body void
where
stmts' = cvtstmts ss
body = case last stmts' of
L _ (ExprStmt body _) -> body
cvtdecs :: [TH.Dec] -> [HsBindGroup RdrName]
cvtdecs [] = []
......@@ -259,12 +268,11 @@ cvtdd (FromThenToR x y z) = (FromThenTo (cvtl x) (cvtl y) (cvtl z))
cvtstmts :: [TH.Stmt] -> [Hs.LStmt RdrName]
cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
cvtstmts [NoBindS e] = [nlResultStmt (cvtl e)] -- when its the last element use ResultStmt
cvtstmts (NoBindS e : ss) = nlExprStmt (cvtl e) : cvtstmts ss
cvtstmts (TH.BindS p e : ss) = nlBindStmt (cvtlp p) (cvtl e) : cvtstmts ss
cvtstmts (TH.LetS ds : ss) = nlLetStmt (cvtdecs ds) : cvtstmts ss
cvtstmts (TH.ParS dss : ss) = nlParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss
cvtstmts [] = []
cvtstmts (NoBindS e : ss) = noLoc (mkExprStmt (cvtl e)) : cvtstmts ss
cvtstmts (TH.BindS p e : ss) = noLoc (mkBindStmt (cvtlp p) (cvtl e)) : cvtstmts ss
cvtstmts (TH.LetS ds : ss) = noLoc (LetStmt (cvtdecs ds)) : cvtstmts ss
cvtstmts (TH.ParS dss : ss) = noLoc (ParStmt [(cvtstmts ds, undefined) | ds <- dss]) : cvtstmts ss
cvtm :: TH.Match -> Hs.LMatch RdrName
cvtm (TH.Match p body wheres)
......@@ -272,14 +280,14 @@ cvtm (TH.Match p body wheres)
cvtguard :: TH.Body -> [LGRHS RdrName]
cvtguard (GuardedB pairs) = map cvtpair pairs
cvtguard (NormalB e) = [noLoc (GRHS [ nlResultStmt (cvtl e) ])]
cvtguard (NormalB e) = [noLoc (GRHS [] (cvtl e))]
cvtpair :: (TH.Guard,TH.Exp) -> LGRHS RdrName
cvtpair (NormalG x,y) = noLoc (GRHS [nlBindStmt truePat (cvtl x),
nlResultStmt (cvtl y)])
cvtpair (PatG x,y) = noLoc (GRHS (cvtstmts x ++ [nlResultStmt (cvtl y)]))
cvtpair (NormalG x,y) = noLoc (GRHS [nlBindStmt truePat (cvtl x)]
(cvtl y))
cvtpair (PatG x,y) = noLoc (GRHS (cvtstmts x) (cvtl y))
cvtOverLit :: Lit -> HsOverLit
cvtOverLit :: Lit -> HsOverLit RdrName
cvtOverLit (IntegerL i) = mkHsIntegral i
cvtOverLit (RationalL r) = mkHsFractional r
-- An Integer is like an an (overloaded) '3' in a Haskell source program
......@@ -297,7 +305,7 @@ cvtlp pat = noLoc (cvtp pat)
cvtp :: TH.Pat -> Hs.Pat RdrName
cvtp (TH.LitP l)
| overloadedLit l = NPatIn (cvtOverLit l) Nothing -- Not right for negative
| overloadedLit l = mkNPat (cvtOverLit l) Nothing -- Not right for negative
-- patterns; need to think
-- about that!
| otherwise = Hs.LitPat (cvtLit l)
......
......@@ -6,6 +6,8 @@ data MatchGroup a
data GRHSs a
type LHsExpr a = SrcLoc.Located (HsExpr a)
type SyntaxExpr a = HsExpr a
type PostTcExpr = HsExpr Var.Id
pprExpr :: (Outputable.OutputableBndr i) =>
HsExpr.HsExpr i -> Outputable.SDoc
......
This diff is collapsed.
......@@ -11,6 +11,7 @@ data MatchGroup a
data GRHSs a
type LHsExpr a = Located (HsExpr a)
type SyntaxExpr a = HsExpr a
pprExpr :: (OutputableBndr i) =>
HsExpr i -> SDoc
......
......@@ -8,8 +8,8 @@ module HsLit where
#include "HsVersions.h"
import {-# SOURCE #-} HsExpr( SyntaxExpr )
import Type ( Type )
import HsTypes ( SyntaxName )
import Outputable
import FastString
import Ratio ( Rational )
......@@ -52,20 +52,24 @@ instance Eq HsLit where
(HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2
lit1 == lit2 = False
data HsOverLit -- An overloaded literal
= HsIntegral Integer SyntaxName -- Integer-looking literals;
-- The name is fromInteger
| HsFractional Rational SyntaxName -- Frac-looking literals
-- The name is fromRational
data HsOverLit id -- An overloaded literal
= HsIntegral Integer (SyntaxExpr id) -- Integer-looking literals;
| HsFractional Rational (SyntaxExpr id) -- Frac-looking literals
-- Before type checking, the SyntaxExpr is 'fromInteger' or 'fromRational'
-- After type checking, it is (fromInteger 3) or lit_78; that is,
-- the expression that should replace the literal.
-- This is unusual, because we're replacing 'fromInteger' with a call
-- to fromInteger. Reason: it allows commoning up of the fromInteger
-- calls, which wouldn't be possible if the desguarar made the application
-- Comparison operations are needed when grouping literals