has_nplusk_pat (ListPat ps _) = any has_nplusk_lpat ps
has_nplusk_pat (TuplePat ps _ _) = any has_nplusk_lpat ps
has_nplusk_pat (PArrPat ps _) = any has_nplusk_lpat ps
-has_nplusk_pat (LazyPat p) = False
+has_nplusk_pat (LazyPat p) = False -- Why?
+has_nplusk_pat (BangPat p) = has_nplusk_lpat p -- I think
has_nplusk_pat p = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat, DictPat
simplify_lpat :: LPat Id -> LPat Id
simplify_pat (VarPatOut id _) = WildPat (idType id) -- Ignore the bindings
simplify_pat (ParPat p) = unLoc (simplify_lpat p)
simplify_pat (LazyPat p) = unLoc (simplify_lpat p)
+simplify_pat (BangPat p) = unLoc (simplify_lpat p)
simplify_pat (AsPat id p) = unLoc (simplify_lpat p)
simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right
#include "HsVersions.h"
-
import Match ( matchWrapper, matchSimply, matchSinglePat )
import MatchLit ( dsLit, dsOverLit )
import DsBinds ( dsLHsBinds, dsCoercion )
%************************************************************************
%* *
-\subsection{dsLet}
+ dsLocalBinds, dsValBinds
%* *
%************************************************************************
-@dsLet@ is a match-result transformer, taking the @MatchResult@ for the body
-and transforming it into one for the let-bindings enclosing the body.
-
-This may seem a bit odd, but (source) let bindings can contain unboxed
-binds like
-\begin{verbatim}
- C x# = e
-\end{verbatim}
-This must be transformed to a case expression and, if the type has
-more than one constructor, may fail.
-
\begin{code}
dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
dsLocalBinds EmptyLocalBinds body = return body
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
-- Silently ignore INLINE and SPECIALISE pragmas...
-ds_val_bind (is_rec, hsbinds) body
+ds_val_bind (NonRecursive, hsbinds) body
| [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
+ (L loc bind : null_binds) <- bagToList binds,
or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
- = ASSERT (case is_rec of {NonRecursive -> True; other -> False})
- -- Unlifted bindings are always non-recursive
- -- and are always a Fun or Pat monobind
- --
- -- ToDo: in some bizarre case it's conceivable that there
- -- could be dict binds in the 'binds'. (See the notes
- -- below. Then pattern-match would fail. Urk.)
- let
+ || isBangHsBind bind
+ = let
body_w_exports = foldr bind_export body exports
bind_export (tvs, g, l, _) body = ASSERT( null tvs )
bindNonRec g (Var l) body
-
- mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID
- (exprType body)
- (showSDoc (ppr pat))
in
- case bagToList binds of
- [L loc (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })]
- -> putSrcSpanDs loc $
- matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
+ ASSERT (null null_binds)
+ -- Non-recursive, non-overloaded bindings only come in ones
+ -- ToDo: in some bizarre case it's conceivable that there
+ -- could be dict binds in the 'binds'. (See the notes
+ -- below. Then pattern-match would fail. Urk.)
+ putSrcSpanDs loc $
+ case bind of
+ FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn }
+ -> matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
ASSERT( null args ) -- Functions aren't lifted
ASSERT( isIdCoercion co_fn )
returnDs (bindNonRec fun rhs body_w_exports)
- [L loc (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })]
+ PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
-> putSrcSpanDs loc $
dsGuarded grhss ty `thenDs` \ rhs ->
mk_error_app pat `thenDs` \ error_expr ->
matchSimply rhs PatBindRhs pat body_w_exports error_expr
other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
+ where
+ mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID
+ (exprType body)
+ (showSDoc (ppr pat))
--- Ordinary case for bindings
+-- Ordinary case for bindings; none should be unlifted
ds_val_bind (is_rec, binds) body
- = dsLHsBinds binds `thenDs` \ prs ->
- returnDs (Let (Rec prs) body)
+ = do { prs <- dsLHsBinds binds
+ ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
+ case prs of
+ [] -> return body
+ other -> return (Let (Rec prs) body) }
-- Use a Rec regardless of is_rec.
-- Why? Because it allows the binds to be all
-- mixed up, which is what happens in one rare case
-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
-- \fail. wrap (case vs of { pats -> rhs fail })
--- where vs are not in the domain of wrap
+-- where vs are not bound by wrap
-- A MatchResult is an expression with a hole in it
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
mkTupleType, mkTupleCase, mkBigCoreTup,
- mkCoreTup, mkCoreTupTy,
+ mkCoreTup, mkCoreTupTy, seqVar,
dsSyntaxTable, lookupEvidence,
; vs <- selectMatchVars ps tys
; return (v:vs) }
+selectMatchVar (BangPat pat) pat_ty = selectMatchVar (unLoc pat) pat_ty
selectMatchVar (LazyPat pat) pat_ty = selectMatchVar (unLoc pat) pat_ty
selectMatchVar (VarPat var) pat_ty = try_for var pat_ty
selectMatchVar (AsPat var pat) pat_ty = try_for (unLoc var) pat_ty
| isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
| otherwise = Let (NonRec new (Var old)) body
+seqVar :: Var -> CoreExpr -> CoreExpr
+seqVar var body = Case (Var var) var (exprType body)
+ [(DEFAULT, [], body)]
+
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult bind match_result
= adjustMatchResult (mkDsLet bind) match_result
tidy1 v wrap (AsPat (L _ var) pat)
= tidy1 v (wrap . wrapBind var v) (unLoc pat)
+tidy1 v wrap (BangPat pat)
+ = tidy1 v (wrap . seqVar v) (unLoc pat)
{- now, here we handle lazy patterns:
tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
data HsBind id
= FunBind { -- FunBind is used for both functions f x = e
-- and variables f = \x -> e
- -- Reason: the Match stuff lets us have an optional
- -- result type sig f :: a->a = ...mentions a...
- --
- -- This also means that instance decls can only have
- -- FunBinds, so if you change this, you'll need to
- -- change e.g. rnMethodBinds
+-- Reason 1: the Match stuff lets us have an optional
+-- result type sig f :: a->a = ...mentions a...
+--
+-- Reason 2: Special case for type inference: see TcBinds.tcMonoBinds
+--
+-- Reason 3: instance decls can only have FunBinds, which is convenient
+-- If you change this, you'll need tochange e.g. rnMethodBinds
fun_id :: Located id,
mkPrefixConPat, mkCharLitPat, mkNilPat,
- isWildPat,
- patsAreAllCons, isConPat, isSigPat,
+ isBangHsBind,
+ patsAreAllCons, isConPat, isSigPat, isWildPat,
patsAreAllLits, isLitPat, isIrrefutableHsPat
) where
import {-# SOURCE #-} HsExpr ( SyntaxExpr )
-- friends:
-import HsBinds ( DictBinds, emptyLHsBinds, pprLHsBinds )
+import HsBinds ( DictBinds, HsBind(..), emptyLHsBinds, pprLHsBinds )
import HsLit ( HsLit(HsCharPrim), HsOverLit )
import HsTypes ( LHsType, PostTcType )
import BasicTypes ( Boxity, tupleParens )
| LazyPat (LPat id) -- Lazy pattern
| AsPat (Located id) (LPat id) -- As pattern
| ParPat (LPat id) -- Parenthesised pattern
+ | BangPat (LPat id) -- Bang patterng
------------ Lists, tuples, arrays ---------------
| ListPat [LPat id] -- Syntactic list
ppr var
pprPat :: (OutputableBndr name) => Pat name -> SDoc
-
-pprPat (VarPat var) = pprPatBndr var
-pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs))
-pprPat (WildPat _) = char '_'
-pprPat (LazyPat pat) = char '~' <> ppr pat
-pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat])
-pprPat (ParPat pat) = parens (ppr pat)
-
+pprPat (VarPat var) = pprPatBndr var
+pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs))
+pprPat (WildPat _) = char '_'
+pprPat (LazyPat pat) = char '~' <> ppr pat
+pprPat (BangPat pat) = char '!' <> ppr pat
+pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat])
+pprPat (ParPat pat) = parens (ppr pat)
pprPat (ListPat pats _) = brackets (interpp'SP pats)
pprPat (PArrPat pats _) = pabrackets (interpp'SP pats)
pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats)
isLitPat (NPlusKPat _ _ _ _) = True
isLitPat other = False
+isBangHsBind :: HsBind id -> Bool
+-- In this module because HsPat is above HsBinds in the import graph
+isBangHsBind (PatBind { pat_lhs = L _ (BangPat p) }) = True
+isBangHsBind bind = False
+
isIrrefutableHsPat :: LPat id -> Bool
-- This function returns False if it's in doubt; specifically
-- on a ConPatIn it doesn't know the size of the constructor family
go1 (VarPat _) = True
go1 (VarPatOut _ _) = True
go1 (LazyPat pat) = True
+ go1 (BangPat pat) = go pat
go1 (ParPat pat) = go pat
go1 (AsPat _ pat) = go pat
go1 (SigPatIn pat _) = go pat
++ bndrs
go (WildPat _) = bndrs
go (LazyPat pat) = collectl pat bndrs
+ go (BangPat pat) = collectl pat bndrs
go (AsPat a pat) = a : collectl pat bndrs
go (ParPat pat) = collectl pat bndrs
collect_pat (TypePat ty) acc = ty:acc
collect_pat (LazyPat pat) acc = collect_lpat pat acc
+collect_pat (BangPat pat) acc = collect_lpat pat acc
collect_pat (AsPat a pat) acc = collect_lpat pat acc
collect_pat (ParPat pat) acc = collect_lpat pat acc
collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
-collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
-collect_pat other acc = acc -- Literals, vars, wildcard
+collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
+collect_pat other acc = acc -- Literals, vars, wildcard
\end{code}
| Opt_Generics
| Opt_ImplicitPrelude
| Opt_ScopedTypeVariables
+ | Opt_BangPatterns
-- optimisation opts
| Opt_Strictness
( "th", Opt_TH ),
( "implicit-prelude", Opt_ImplicitPrelude ),
( "scoped-type-variables", Opt_ScopedTypeVariables ),
+ ( "bang-patterns", Opt_BangPatterns ),
( "monomorphism-restriction", Opt_MonomorphismRestriction ),
( "implicit-params", Opt_ImplicitParams ),
( "allow-overlapping-instances", Opt_AllowOverlappingInstances ),
Opt_FFI,
Opt_TH,
Opt_ImplicitParams,
- Opt_ScopedTypeVariables ]
+ Opt_ScopedTypeVariables,
+ Opt_BangPatterns ]
isFFlag f = f `elem` (map fst fFlags)
getFFlag f = fromJust (lookup f fFlags)
P(..), ParseResult(..), getSrcLoc,
failLocMsgP, failSpanMsgP, srcParseFail,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
- getLexState, popLexState, pushLexState
+ getLexState, popLexState, pushLexState,
+ extension, bangPatEnabled
) where
#include "HsVersions.h"
thBit = 5
ipBit = 6
tvBit = 7 -- Scoped type variables enables 'forall' keyword
+bangPatBit = 8 -- Tells the parser to understand bang-patterns
+ -- (doesn't affect the lexer)
glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
glaExtsEnabled flags = testBit flags glaExtsBit
thEnabled flags = testBit flags thBit
ipEnabled flags = testBit flags ipBit
tvEnabled flags = testBit flags tvBit
+bangPatEnabled flags = testBit flags bangPatBit
-- create a parse state
--
.|. thBit `setBitIf` dopt Opt_TH flags
.|. ipBit `setBitIf` dopt Opt_ImplicitParams flags
.|. tvBit `setBitIf` dopt Opt_ScopedTypeVariables flags
+ .|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
decl :: { Located (OrdList (LHsDecl RdrName)) }
: sigdecl { $1 }
+ | '!' infixexp rhs {% do { pat <- checkPattern $2;
+ return (LL $ unitOL $ LL $ ValD $
+ PatBind (LL $ BangPat pat) (unLoc $3)
+ placeHolderType placeHolderNames) } }
| infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3;
return (LL $ unitOL (LL $ ValD r)) } }
aexp :: { LHsExpr RdrName }
: qvar '@' aexp { LL $ EAsPat $1 $3 }
| '~' aexp { LL $ ELazyPat $2 }
+-- | '!' aexp { LL $ EBangPat $2 }
| aexp1 { $1 }
aexp1 :: { LHsExpr RdrName }
| INTEGER { L1 (HsOverLit $! mkHsIntegral (getINTEGER $1)) }
| RATIONAL { L1 (HsOverLit $! mkHsFractional (getRATIONAL $1)) }
| '(' exp ')' { LL (HsPar $2) }
- | '(' exp ',' texps ')' { LL $ ExplicitTuple ($2 : reverse $4) Boxed }
+ | '(' texp ',' texps ')' { LL $ ExplicitTuple ($2 : reverse $4) Boxed }
| '(#' texps '#)' { LL $ ExplicitTuple (reverse $2) Unboxed }
| '[' list ']' { LL (unLoc $2) }
| '[:' parr ':]' { LL (unLoc $2) }
: {- empty -} { [] }
| cvtopdecls { $1 }
+texp :: { LHsExpr RdrName }
+ : exp { $1 }
+ | qopm infixexp { LL $ SectionR $1 $2 }
+ -- The second production is really here only for bang patterns
+ -- but
+
texps :: { [LHsExpr RdrName] }
- : texps ',' exp { $3 : $1 }
- | exp { [$1] }
+ : texps ',' texp { $3 : $1 }
+ | texp { [$1] }
-----------------------------------------------------------------------------
-- avoiding another shift/reduce-conflict.
list :: { LHsExpr RdrName }
- : exp { L1 $ ExplicitList placeHolderType [$1] }
+ : texp { L1 $ ExplicitList placeHolderType [$1] }
| lexps { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) }
- | exp '..' { LL $ ArithSeq noPostTcExpr (From $1) }
- | exp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
- | exp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
- | exp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
- | exp pquals { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 }
+ | texp '..' { LL $ ArithSeq noPostTcExpr (From $1) }
+ | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
+ | texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
+ | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
+ | texp pquals { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 }
lexps :: { Located [LHsExpr RdrName] }
- : lexps ',' exp { LL ($3 : unLoc $1) }
- | exp ',' exp { LL [$3,$1] }
+ : lexps ',' texp { LL ($3 : unLoc $1) }
+ | texp ',' texp { LL [$3,$1] }
-----------------------------------------------------------------------------
-- List Comprehensions
isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace )
import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
-import Lexer ( P, failSpanMsgP )
+import Lexer ( P, failSpanMsgP, extension, bangPatEnabled )
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
DNCallSpec(..), DNKind(..), CLabelString )
checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
checkPat loc (L l (HsVar c)) args
| isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
-checkPat loc (L _ (HsApp f x)) args = do
- x <- checkLPat x
- checkPat loc f (x:args)
-checkPat loc (L _ e) [] = do
- p <- checkAPat loc e
- return (L loc p)
+checkPat loc e args -- OK to let this happen even if bang-patterns
+ -- are not enabled, because there is no valid
+ -- non-bang-pattern parse of (C ! e)
+ | Just (e', args') <- splitBang e
+ = do { args'' <- checkPatterns args'
+ ; checkPat loc e' (args'' ++ args) }
+checkPat loc (L _ (HsApp f x)) args
+ = do { x <- checkLPat x; checkPat loc f (x:args) }
+checkPat loc (L _ e) []
+ = do { p <- checkAPat loc e; return (L loc p) }
checkPat loc pat _some_args
= patFail loc
NegApp (L _ (HsOverLit pos_lit)) _
-> return (mkNPat pos_lit (Just noSyntaxExpr))
- ELazyPat e -> checkLPat e >>= (return . LazyPat)
- EAsPat n e -> checkLPat e >>= (return . AsPat n)
+ SectionR (L _ (HsVar bang)) e
+ | bang == bang_RDR -> checkLPat e >>= (return . BangPat)
+ ELazyPat e -> checkLPat e >>= (return . LazyPat)
+ EAsPat n e -> checkLPat e >>= (return . AsPat n)
ExprWithTySig e t -> checkLPat e >>= \e ->
-- Pattern signatures are parsed as sigtypes,
-- but they aren't explicit forall points. Hence
(L _ (HsOverLit lit@(HsIntegral _ _)))
| plus == plus_RDR
-> return (mkNPlusKPat (L nloc n) lit)
- where
- plus_RDR = mkUnqual varName FSLIT("+") -- Hack
OpApp l op fix r -> checkLPat l >>= \l ->
checkLPat r >>= \r ->
HsType ty -> return (TypePat ty)
_ -> patFail loc
+plus_RDR, bang_RDR :: RdrName
+plus_RDR = mkUnqual varName FSLIT("+") -- Hack
+bang_RDR = mkUnqual varName FSLIT("!") -- Hack
+
checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
checkPatField (n,e) = do
p <- checkLPat e
---------------------------------------------------------------------------
-- Check Equation Syntax
-checkValDef
- :: LHsExpr RdrName
- -> Maybe (LHsType RdrName)
- -> Located (GRHSs RdrName)
- -> P (HsBind RdrName)
-
-checkValDef lhs opt_sig (L rhs_span grhss)
- | Just (f,inf,es) <- isFunLhs lhs
- = if isQual (unLoc f)
- then parseError (getLoc f) ("Qualified name in function definition: " ++
- showRdrName (unLoc f))
- else do ps <- checkPatterns es
- let match_span = combineSrcSpans (getLoc lhs) rhs_span
- matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)]
- return (FunBind { fun_id = f, fun_infix = inf, fun_matches = matches,
- fun_co_fn = idCoercion, bind_fvs = placeHolderNames })
+checkValDef :: LHsExpr RdrName
+ -> Maybe (LHsType RdrName)
+ -> Located (GRHSs RdrName)
+ -> P (HsBind RdrName)
+
+checkValDef lhs opt_sig grhss
+ = do { mb_fun <- isFunLhs lhs
+ ; case mb_fun of
+ Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
+ fun is_infix pats opt_sig grhss
+ Nothing -> checkPatBind lhs grhss }
+
+checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+ | isQual (unLoc fun)
+ = parseError (getLoc fun) ("Qualified name in function definition: " ++
+ showRdrName (unLoc fun))
+ | otherwise
+ = do ps <- checkPatterns pats
+ let match_span = combineSrcSpans lhs_loc rhs_span
+ matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)]
+ return (FunBind { fun_id = fun, fun_infix = is_infix, fun_matches = matches,
+ fun_co_fn = idCoercion, bind_fvs = placeHolderNames })
-- The span of the match covers the entire equation.
-- That isn't quite right, but it'll do for now.
- | otherwise = do
- lhs <- checkPattern lhs
- return (PatBind lhs grhss placeHolderType placeHolderNames)
+
+checkPatBind lhs (L _ grhss)
+ = do { lhs <- checkPattern lhs
+ ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
checkValSig
:: LHsExpr RdrName
-- A variable binding is parsed as a FunBind.
-isFunLhs :: LHsExpr RdrName
- -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
+
+ -- The parser left-associates, so there should
+ -- not be any OpApps inside the e's
+splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
+-- Splits (f ! g a b) into (f, [(! g), a, g])
+splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
+ | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
+ where
+ (arg1,argns) = split_bang r_arg []
+ split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
+ split_bang e es = (e,es)
+splitBang other = Nothing
+
+isFunLhs :: LHsExpr RdrName
+ -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
+-- Just (fun, is_infix, arg_pats) if e is a function LHS
isFunLhs e = go e []
where
go (L loc (HsVar f)) es
- | not (isRdrDataCon f) = Just (L loc f, False, es)
+ | not (isRdrDataCon f) = return (Just (L loc f, False, es))
go (L _ (HsApp f e)) es = go f (e:es)
go (L _ (HsPar e)) es@(_:_) = go e es
- go (L loc (OpApp l (L loc' (HsVar op)) fix r)) es
- | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
- | otherwise =
- case go l es of
- Just (op', True, j : k : es') ->
- Just (op', True,
- j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
- _ -> Nothing
- go _ _ = Nothing
+ go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
+ | Just (e',es') <- splitBang e
+ = do { bang_on <- extension bangPatEnabled
+ ; if bang_on then go e' (es' ++ es)
+ else return (Just (L loc' op, True, (l:r:es))) }
+ -- No bangs; behave just like the next case
+ | not (isRdrDataCon op)
+ = return (Just (L loc' op, True, (l:r:es)))
+ | otherwise
+ = do { mb_l <- go l es
+ ; case mb_l of
+ Just (op', True, j : k : es')
+ -> return (Just (op', True, j : op_app : es'))
+ where
+ op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
+ _ -> return Nothing }
+ go _ _ = return Nothing
---------------------------------------------------------------------------
-- Miscellaneous utilities
We return a (bogus) EWildPat in each case.
\begin{code}
-rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
- returnM (EWildPat, emptyFVs)
-
-rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
- returnM (EWildPat, emptyFVs)
-
-rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
- returnM (EWildPat, emptyFVs)
+rnExpr e@EWildPat = patSynErr e
+rnExpr e@(EAsPat {}) = patSynErr e
+rnExpr e@(ELazyPat {}) = patSynErr e
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-patSynErr e
- = sep [ptext SLIT("Pattern syntax in expression context:"),
- nest 4 (ppr e)]
+patSynErr e = do { addErr (sep [ptext SLIT("Pattern syntax in expression context:"),
+ nest 4 (ppr e)])
+ ; return (EWildPat, emptyFVs) }
parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
= rnPred doc pred `thenM` \ pred' ->
returnM (HsPredTy pred')
+rnHsType doc (HsSpliceTy _)
+ = do { addErr (ptext SLIT("Type splices are not yet implemented"))
+ ; failM }
+
rnLHsTypes doc tys = mappM (rnLHsType doc) tys
\end{code}
= rnLPat pat `thenM` \ (pat', fvs) ->
returnM (LazyPat pat', fvs)
+rnPat (BangPat pat)
+ = rnLPat pat `thenM` \ (pat', fvs) ->
+ returnM (BangPat pat', fvs)
+
rnPat (AsPat name pat)
= rnLPat pat `thenM` \ (pat', fvs) ->
lookupLocatedBndrRn name `thenM` \ vname ->
HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames,
isVanillaLSig, sigName, placeHolderNames, isPragLSig,
LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce,
- collectHsBindBinders, collectPatBinders, pprPatBind
+ collectHsBindBinders, collectPatBinders, pprPatBind, isBangHsBind
)
import TcHsSyn ( zonkId )
-- These must be non-recursive etc, and are not generalised
-- They desugar to a case expression in the end
; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
- ; if any isUnLiftedType zonked_mono_tys then
- do { -- Unlifted bindings
- checkUnliftedBinds top_lvl rec_group binds' mono_bind_infos
- ; extendLIEs lie_req
- ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
+ ; is_strict <- checkStrictBinds top_lvl rec_group binds'
+ zonked_mono_tys mono_bind_infos
+ ; if is_strict then
+ do { extendLIEs lie_req
+ ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id, [])
-- ToDo: prags for unlifted bindings
-- b) not top level,
-- c) not a multiple-binding group (more or less implied by (a))
-checkUnliftedBinds :: TopLevelFlag -> RecFlag
- -> LHsBinds TcId -> [MonoBindInfo] -> TcM ()
-checkUnliftedBinds top_lvl rec_group mbind infos
+checkStrictBinds :: TopLevelFlag -> RecFlag
+ -> LHsBinds TcId -> [TcType] -> [MonoBindInfo]
+ -> TcM Bool
+checkStrictBinds top_lvl rec_group mbind mono_tys infos
+ | unlifted || bang_pat
= do { checkTc (isNotTopLevel top_lvl)
- (unliftedBindErr "Top-level" mbind)
+ (strictBindErr "Top-level" unlifted mbind)
; checkTc (isNonRec rec_group)
- (unliftedBindErr "Recursive" mbind)
+ (strictBindErr "Recursive" unlifted mbind)
; checkTc (isSingletonBag mbind)
- (unliftedBindErr "Multiple" mbind)
- ; mapM_ check_sig infos }
+ (strictBindErr "Multiple" unlifted mbind)
+ ; mapM_ check_sig infos
+ ; return True }
+ | otherwise
+ = return False
where
+ unlifted = any isUnLiftedType mono_tys
+ bang_pat = anyBag (isBangHsBind . unLoc) mbind
check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig))
- (badUnliftedSig sig)
+ (badStrictSig unlifted sig)
check_sig other = return ()
+
+strictBindErr flavour unlifted mbind
+ = hang (text flavour <+> msg <+> ptext SLIT("aren't allowed:")) 4 (ppr mbind)
+ where
+ msg | unlifted = ptext SLIT("bindings for unlifted types")
+ | otherwise = ptext SLIT("bang-pattern bindings")
+
+badStrictSig unlifted sig
+ = hang (ptext SLIT("Illegal polymorphic signature in") <+> msg)
+ 4 (ppr sig)
+ where
+ msg | unlifted = ptext SLIT("an unlifted binding")
+ | otherwise = ptext SLIT("a bang-pattern binding")
\end{code}
\begin{code}
tcMonoBinds :: [LHsBind Name]
-> TcSigFun
- -> RecFlag -- True <=> the binding is recursive for typechecking purposes
- -- i.e. the binders are mentioned in their RHSs, and
- -- we are not resuced by a type signature
+ -> RecFlag -- Whether the binding is recursive for typechecking purposes
+ -- i.e. the binders are mentioned in their RHSs, and
+ -- we are not resuced by a type signature
-> TcM (LHsBinds TcId, [MonoBindInfo])
tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
-----------------------------------------------
-unliftedBindErr flavour mbind
- = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
- 4 (ppr mbind)
-
-badUnliftedSig sig
- = hang (ptext SLIT("Illegal polymorphic signature in an unlifted binding"))
- 4 (ppr sig)
-
------------------------------------------------
unboxedTupleErr name ty
= hang (ptext SLIT("Illegal binding of unboxed tuple"))
4 (ppr name <+> dcolon <+> ppr ty)
pat_type (WildPat ty) = ty
pat_type (VarPat var) = idType var
pat_type (VarPatOut var _) = idType var
+pat_type (BangPat pat) = hsPatType pat
pat_type (LazyPat pat) = hsPatType pat
pat_type (LitPat lit) = hsLitType lit
pat_type (AsPat var pat) = idType (unLoc var)
= do { (env', pat') <- zonkPat env pat
; return (env', LazyPat pat') }
+zonk_pat env (BangPat pat)
+ = do { (env', pat') <- zonkPat env pat
+ ; return (env', BangPat pat') }
+
zonk_pat env (AsPat (L loc v) pat)
= do { v' <- zonkIdBndr env v
; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
= do { (pat', tvs, res) <- tc_lpat pstate pat pat_ty thing_inside
; return (ParPat pat', tvs, res) }
+tc_pat pstate (BangPat pat) pat_ty thing_inside
+ = do { (pat', tvs, res) <- tc_lpat pstate pat pat_ty thing_inside
+ ; return (BangPat pat', tvs, res) }
+
-- There's a wrinkle with irrefuatable patterns, namely that we
-- must not propagate type refinement from them. For example
-- data T a where { T1 :: Int -> T Int; ... }
projects / ghc-hetmet.git / commitdiff