From: simonpj@microsoft.com Date: Fri, 3 Feb 2006 17:51:08 +0000 (+0000) Subject: Add bang patterns X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=5d3051c66796dcf884b052f9e4afc3ed19b9f514 Add bang patterns This commit adds bang-patterns, enabled by -fglasgow-exts or -fbang-patterns diabled by -fno-bang-patterns The idea is described here http://haskell.galois.com/cgi-bin/haskell-prime/trac.cgi/wiki/BangPatterns --- diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 693368b..9aac5ce 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -611,7 +611,8 @@ has_nplusk_pat (ConPatOut _ _ _ _ ps ty) = any has_nplusk_lpat (hsConArgs ps) 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 @@ -623,6 +624,7 @@ simplify_pat (VarPat id) = WildPat (idType 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 diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 164316c..79303ef 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -8,7 +8,6 @@ module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where #include "HsVersions.h" - import Match ( matchWrapper, matchSimply, matchSinglePat ) import MatchLit ( dsLit, dsOverLit ) import DsBinds ( dsLHsBinds, dsCoercion ) @@ -60,21 +59,10 @@ import FastString %************************************************************************ %* * -\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 @@ -101,45 +89,48 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr -- 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 diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 75fd45b..2c43a54 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -83,7 +83,7 @@ idWrapper e = e -- 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 diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 70944f8..b42bd7d 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -27,7 +27,7 @@ module DsUtils ( mkSelectorBinds, mkTupleExpr, mkTupleSelector, mkTupleType, mkTupleCase, mkBigCoreTup, - mkCoreTup, mkCoreTupTy, + mkCoreTup, mkCoreTupTy, seqVar, dsSyntaxTable, lookupEvidence, @@ -169,6 +169,7 @@ selectMatchVars (p:ps) (ty:tys) = do { v <- selectMatchVar p ty ; 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 @@ -255,6 +256,10 @@ wrapBind new old body | 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 diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 19cace8..bbc37b3 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -410,6 +410,8 @@ tidy1 v wrap (VarPatOut var binds) 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 : diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 23208f0..69b75b4 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -58,12 +58,13 @@ type LHsBind id = Located (HsBind id) 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, diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index eca7dd1..953d228 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -11,8 +11,8 @@ module HsPat ( mkPrefixConPat, mkCharLitPat, mkNilPat, - isWildPat, - patsAreAllCons, isConPat, isSigPat, + isBangHsBind, + patsAreAllCons, isConPat, isSigPat, isWildPat, patsAreAllLits, isLitPat, isIrrefutableHsPat ) where @@ -22,7 +22,7 @@ module HsPat ( 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 ) @@ -53,6 +53,7 @@ data Pat id | 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 @@ -156,14 +157,13 @@ pprPatBndr var -- Print with type info if -dppr-debug is on 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) @@ -282,6 +282,11 @@ isLitPat (NPat _ _ _ _) = True 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 @@ -295,6 +300,7 @@ isIrrefutableHsPat pat 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 diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index df4885f..d9c45e6 100644 --- a/ghc/compiler/hsSyn/HsUtils.lhs +++ b/ghc/compiler/hsSyn/HsUtils.lhs @@ -376,6 +376,7 @@ collectl (L l pat) bndrs ++ 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 @@ -411,11 +412,12 @@ collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc) 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} diff --git a/ghc/compiler/main/DynFlags.hs b/ghc/compiler/main/DynFlags.hs index 4758bfb..9d279d6 100644 --- a/ghc/compiler/main/DynFlags.hs +++ b/ghc/compiler/main/DynFlags.hs @@ -152,6 +152,7 @@ data DynFlag | Opt_Generics | Opt_ImplicitPrelude | Opt_ScopedTypeVariables + | Opt_BangPatterns -- optimisation opts | Opt_Strictness @@ -968,6 +969,7 @@ fFlags = [ ( "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 ), @@ -993,7 +995,8 @@ glasgowExtsFlags = [ 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) diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x index 3d5ebd3..90fbf7a 100644 --- a/ghc/compiler/parser/Lexer.x +++ b/ghc/compiler/parser/Lexer.x @@ -26,7 +26,8 @@ module Lexer ( P(..), ParseResult(..), getSrcLoc, failLocMsgP, failSpanMsgP, srcParseFail, popContext, pushCurrentContext, setLastToken, setSrcLoc, - getLexState, popLexState, pushLexState + getLexState, popLexState, pushLexState, + extension, bangPatEnabled ) where #include "HsVersions.h" @@ -1257,6 +1258,8 @@ arrowsBit = 4 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 @@ -1266,6 +1269,7 @@ arrowsEnabled flags = testBit flags arrowsBit thEnabled flags = testBit flags thBit ipEnabled flags = testBit flags ipBit tvEnabled flags = testBit flags tvBit +bangPatEnabled flags = testBit flags bangPatBit -- create a parse state -- @@ -1290,6 +1294,7 @@ mkPState buf loc flags = .|. 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 diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 0a423f4..156cedc 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -968,6 +968,10 @@ deriving :: { Located (Maybe [LHsType RdrName]) } 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)) } } @@ -1063,6 +1067,7 @@ aexps :: { [LHsExpr RdrName] } aexp :: { LHsExpr RdrName } : qvar '@' aexp { LL $ EAsPat $1 $3 } | '~' aexp { LL $ ELazyPat $2 } +-- | '!' aexp { LL $ EBangPat $2 } | aexp1 { $1 } aexp1 :: { LHsExpr RdrName } @@ -1086,7 +1091,7 @@ aexp2 :: { 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) } @@ -1128,9 +1133,15 @@ cvtopdecls0 :: { [LHsDecl RdrName] } : {- 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] } ----------------------------------------------------------------------------- @@ -1140,17 +1151,17 @@ texps :: { [LHsExpr RdrName] } -- 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 diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 5c5f7d1..8d59e2b 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -54,7 +54,7 @@ import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, 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 ) @@ -499,12 +499,16 @@ checkLPat e@(L l _) = checkPat l e [] 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 @@ -523,8 +527,10 @@ checkAPat loc e = case e of 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 @@ -540,8 +546,6 @@ checkAPat loc e = case e of (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 -> @@ -565,6 +569,10 @@ checkAPat loc e = case e of 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 @@ -576,27 +584,34 @@ patFail loc = parseError loc "Parse error in pattern" --------------------------------------------------------------------------- -- 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 @@ -635,23 +650,45 @@ mkGadtDecl name ty = ConDecl -- 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 diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 95d7b83..a128c35 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -255,14 +255,9 @@ Since all the symbols are reservedops we can simply reject them. 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} %************************************************************************ @@ -943,9 +938,9 @@ mkAssertErrorExpr %************************************************************************ \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")) diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index bfd0289..d7d435c 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -185,6 +185,10 @@ rnHsType doc (HsPredTy pred) = 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} @@ -594,6 +598,10 @@ rnPat (LazyPat pat) = 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 -> diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 38f4306..c765699 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -22,7 +22,7 @@ import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..), HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, isVanillaLSig, sigName, placeHolderNames, isPragLSig, LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce, - collectHsBindBinders, collectPatBinders, pprPatBind + collectHsBindBinders, collectPatBinders, pprPatBind, isBangHsBind ) import TcHsSyn ( zonkId ) @@ -347,11 +347,11 @@ tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds -- 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 @@ -469,20 +469,40 @@ forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) -- 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} @@ -498,9 +518,9 @@ The signatures have been dealt with already. \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, @@ -1083,15 +1103,6 @@ sigContextsCtxt sig1 sig2 ----------------------------------------------- -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) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 4289c2c..c938a76 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -78,6 +78,7 @@ pat_type (ParPat pat) = hsPatType pat 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) @@ -713,6 +714,10 @@ zonk_pat env (LazyPat pat) = 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 diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index ae55767..ce9e99b 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -274,6 +274,10 @@ tc_pat pstate (ParPat pat) pat_ty thing_inside = 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; ... }