Commit 5d3051c6 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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
parent 7985849b
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 :
......
......@@ -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,
......
......@@ -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
......
......@@ -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}
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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"))
......
......@@ -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 ->
......
......@@ -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 ()