Functions over HsSyn specialised to RdrName.
\begin{code}
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
module RdrHsSyn (
extractHsTyRdrTyVars,
extractHsRhoRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl,
- mkHsNegApp, mkHsIntegral, mkHsFractional,
+ mkHsOpApp, mkClassDecl,
+ mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
cvBindGroup,
- cvBindsAndSigs,
+ cvBindsAndSigs,
cvTopDecls,
- findSplice, mkGroup,
+ findSplice, checkDecBrGroup,
-- Stuff to do with Foreign declarations
CallConv(..),
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPred, -- HsType -> P HsPred
- checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
- checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
+ checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
+ checkTyVars, -- [LHsType RdrName] -> P ()
+ checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
+ checkKindSigs, -- [LTyClDecl RdrName] -> P ()
checkInstType, -- HsType -> P HsType
+ checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
checkPattern, -- HsExp -> P HsPat
+ bang_RDR,
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
checkDo, -- [Stmt] -> P [Stmt]
checkMDo, -- [Stmt] -> P [Stmt]
#include "HsVersions.h"
import HsSyn -- Lots of it
-import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
+import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace )
import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
-import Lexer ( P, failSpanMsgP, extension, bangPatEnabled )
+import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
DNCallSpec(..), DNKind(..), CLabelString )
import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
import Outputable
import FastString
-import Panic
import List ( isSuffixOf, nubBy )
+import Monad ( unless )
\end{code}
extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
-extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
-extract_pred (HsIParam n ty) acc = extract_lty ty acc
+extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
+extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
+extract_pred (HsIParam n ty ) acc = extract_lty ty acc
extract_lty (L loc ty) acc
= case ty of
extract_lctxt cx (extract_lty ty []))
where
locals = hsLTyVarNames tvs
+ HsDocTy ty doc -> extract_lty ty acc
extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
*** See "THE NAMING STORY" in HsDecls ****
\begin{code}
-mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
+mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
= ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
tcdFDs = fds,
tcdSigs = sigs,
- tcdMeths = mbinds
+ tcdMeths = mbinds,
+ tcdATs = ats,
+ tcdDocs = docs
}
-mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
+mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
= TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
- tcdTyVars = tyvars, tcdCons = data_cons,
+ tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
tcdKindSig = ksig, tcdDerivs = maybe_deriv }
\end{code}
-\begin{code}
-mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
--- RdrName If the type checker sees (negate 3#) it will barf, because negate
--- can't take an unboxed arg. But that is exactly what it will see when
--- we write "-3#". So we have to do the negation right now!
-mkHsNegApp (L loc e) = f e
- where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
- f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
- f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
- f expr = NegApp (L loc e) noSyntaxExpr
-\end{code}
-
%************************************************************************
%* *
\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
where (L l' b', ds') = getMonoBind (L l b) ds
go (d : ds) = d : go ds
+-- Declaration list may only contain value bindings and signatures.
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
- = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
- ValBindsIn mbs sigs
- }
+ = case cvBindsAndSigs binding of
+ (mbs, sigs, [], _) -> -- list of type decls *always* empty
+ ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
- -> (Bag (LHsBind RdrName), [LSig RdrName])
+ -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
-- Input decls contain just value bindings and signatures
+-- and in case of class or instance declarations also
+-- associated type declarations. They might also contain Haddock comments.
cvBindsAndSigs fb = go (fromOL fb)
where
- go [] = (emptyBag, [])
- go (L l (SigD s) : ds) = (bs, L l s : ss)
- where (bs,ss) = go ds
- go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
- where (b',ds') = getMonoBind (L l b) ds
- (bs,ss) = go ds'
+ go [] = (emptyBag, [], [], [])
+ go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, docs)
+ where (bs, ss, ts, docs) = go ds
+ go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
+ where (b', ds') = getMonoBind (L l b) ds
+ (bs, ss, ts, docs) = go ds'
+ go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
+ where (bs, ss, ts, docs) = go ds
+ go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
+ where (bs, ss, ts, docs) = go ds
-----------------------------------------------------------------------------
-- Group function bindings into equation groups
-- belong with b into a single MonoBinds, and ds' is the depleted
-- list of parsed bindings.
--
+-- All Haddock comments between equations inside the group are
+-- discarded.
+--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
fun_matches = MatchGroup mtchs1 _ })) binds
| has_args mtchs1
- = go is_infix1 mtchs1 loc1 binds
+ = go is_infix1 mtchs1 loc1 binds []
where
go is_infix mtchs loc
(L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
- fun_matches = MatchGroup mtchs2 _ })) : binds)
+ fun_matches = MatchGroup mtchs2 _ })) : binds) _
| f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
- (combineSrcSpans loc loc2) binds
- go is_infix mtchs loc binds
- = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds)
+ (combineSrcSpans loc loc2) binds []
+ go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
+ = let doc_decls' = doc_decl : doc_decls
+ in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
+ go is_infix mtchs loc binds doc_decls
+ = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
-- Reverse the final matches, to get it back in the right order
+ -- Do the same thing with the trailing doc comments
getMonoBind bind binds = (bind, binds)
findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
findSplice ds = addl emptyRdrGroup ds
-mkGroup :: [LHsDecl a] -> HsGroup a
-mkGroup ds = addImpDecls emptyRdrGroup ds
-
-addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
--- The decls are imported, and should not have a splice
-addImpDecls group decls = case addl group decls of
- (group', Nothing) -> group'
- other -> panic "addImpDecls"
+checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
+-- Turn the body of a [d| ... |] into a HsGroup
+-- There should be no splices in the "..."
+checkDecBrGroup decls
+ = case addl emptyRdrGroup decls of
+ (group, Nothing) -> return group
+ (_, Just (SpliceDecl (L loc _), _)) ->
+ parseError loc "Declaration splices are not permitted inside declaration brackets"
+ -- Why not? See Section 7.3 of the TH paper.
addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-- This stuff reverses the declarations (again) but it doesn't matter
add gp l (SpliceD e) ds = (gp, Just (e, ds))
-- Class declarations: pull out the fixity signatures to the top
-add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
+ l (TyClD d) ds
| isClassDecl d =
let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
- addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
+ addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
| otherwise =
addl (gp { hs_tyclds = L l d : ts }) ds
-- The rest are routine
add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
= addl (gp { hs_instds = L l d : ts }) ds
+add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
+ = addl (gp { hs_derivds = L l d : ts }) ds
add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
= addl (gp { hs_defds = L l d : ts }) ds
-add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
+add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
= addl (gp { hs_fords = L l d : ts }) ds
add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
= addl (gp { hs_depds = L l d : ts }) ds
add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
= addl (gp { hs_ruleds = L l d : ts }) ds
+add gp l (DocD d) ds
+ = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
+
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
\end{code}
-- arguments, and converts the type constructor back into a data constructor.
mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
- -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
+ -> P (Located RdrName, HsConDeclDetails RdrName)
mkPrefixCon ty tys
= split ty tys
where
return (data_con, PrefixCon ts)
split (L l _) _ = parseError l "parse error in data/newtype declaration"
-mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
- -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
+mkRecCon :: Located RdrName ->
+ [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
+ P (Located RdrName, HsConDeclDetails RdrName)
mkRecCon (L loc con) fields
= do data_con <- tyConToDataCon loc con
- return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
+ return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
ty -> do dict_ty <- checkDictTy (L l ty)
return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
-checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-checkTyVars tvs
- = mapM chk tvs
+checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
+checkDictTy (L spn ty) = check ty []
+ where
+ check (HsTyVar t) args | not (isRdrTyVar t)
+ = return (L spn (HsPredTy (HsClassP t args)))
+ check (HsAppTy l r) args = check (unLoc l) (r:args)
+ check (HsParTy t) args = check (unLoc t) args
+ check _ _ = parseError spn "Malformed instance header"
+
+-- Check whether the given list of type parameters are all type variables
+-- (possibly with a kind signature). If the second argument is `False',
+-- only type variables are allowed and we raise an error on encountering a
+-- non-variable; otherwise, we allow non-variable arguments and return the
+-- entire list of parameters.
+--
+checkTyVars :: [LHsType RdrName] -> P ()
+checkTyVars tparms = mapM_ chk tparms
where
- -- Check that the name space is correct!
+ -- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
- | isRdrTyVar tv = return (L l (KindedTyVar tv k))
+ | isRdrTyVar tv = return ()
chk (L l (HsTyVar tv))
- | isRdrTyVar tv = return (L l (UserTyVar tv))
- chk (L l other)
- = parseError l "Type found where type variable expected"
-
-checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
-checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
- ; return (tc, tvs) }
-
+ | isRdrTyVar tv = return ()
+ chk (L l other) =
+ parseError l "Type found where type variable expected"
+
+-- Check whether the type arguments in a type synonym head are simply
+-- variables. If not, we have a type family instance and return all patterns.
+-- If yes, we return 'Nothing' as the third component to indicate a vanilla
+-- type synonym.
+--
+checkSynHdr :: LHsType RdrName
+ -> Bool -- is type instance?
+ -> P (Located RdrName, -- head symbol
+ [LHsTyVarBndr RdrName], -- parameters
+ [LHsType RdrName]) -- type patterns
+checkSynHdr ty isTyInst =
+ do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
+ ; unless isTyInst $ checkTyVars tparms
+ ; return (tc, tvs, tparms) }
+
+
+-- Well-formedness check and decomposition of type and class heads.
+--
checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
- -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+ -> P (LHsContext RdrName, -- the type context
+ Located RdrName, -- the head symbol (type or class name)
+ [LHsTyVarBndr RdrName], -- free variables of the non-context part
+ [LHsType RdrName]) -- parameters of head symbol
-- The header of a type or class decl should look like
-- (C a, D b) => T a b
-- or T a b
-- or a + b
-- etc
+-- With associated types, we can also have non-variable parameters; ie,
+-- T Int [a]
+-- or Int :++: [a]
+-- The unaltered parameter list is returned in the fourth component of the
+-- result. Eg, for
+-- T Int [a]
+-- we return
+-- ('()', 'T', ['a'], ['Int', '[a]'])
checkTyClHdr (L l cxt) ty
- = do (tc, tvs) <- gol ty []
+ = do (tc, tvs, parms) <- gol ty []
mapM_ chk_pred cxt
- return (L l cxt, tc, tvs)
+ return (L l cxt, tc, tvs, parms)
where
gol (L l ty) acc = go l ty acc
- go l (HsTyVar tc) acc
- | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
- return (L l tc, tvs)
- go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
- return (tc, tvs)
+ go l (HsTyVar tc) acc
+ | isRdrTc tc = do tvs <- extractTyVars acc
+ return (L l tc, tvs, acc)
+ go l (HsOpTy t1 ltc@(L _ tc) t2) acc
+ | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
+ return (ltc, tvs, t1:t2:acc)
go l (HsParTy ty) acc = gol ty acc
go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
- go l other acc = parseError l "Malformed LHS to type of class declaration"
-
- -- The predicates in a type or class decl must all
- -- be HsClassPs. They need not all be type variables,
- -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m
- chk_pred (L l (HsClassP _ args)) = return ()
+ go l other acc =
+ parseError l "Malformed head of type or class declaration"
+
+ -- The predicates in a type or class decl must be class predicates or
+ -- equational constraints. They need not all have variable-only
+ -- arguments, even in Haskell 98.
+ -- E.g. class (Monad m, Monad (t m)) => MonadT t m
+ chk_pred (L l (HsClassP _ _)) = return ()
+ chk_pred (L l (HsEqualP _ _)) = return ()
chk_pred (L l _)
= parseError l "Malformed context in type or class declaration"
-
+-- Extract the type variables of a list of type parameters.
+--
+-- * Type arguments can be complex type terms (needed for associated type
+-- declarations).
+--
+extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
+extractTyVars tvs = collects [] tvs
+ where
+ -- Collect all variables (1st arg serves as an accumulator)
+ collect tvs (L l (HsForAllTy _ _ _ _)) =
+ parseError l "Forall type not allowed as type parameter"
+ collect tvs (L l (HsTyVar tv))
+ | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
+ | otherwise = return tvs
+ collect tvs (L l (HsBangTy _ _ )) =
+ parseError l "Bang-style type annotations not allowed as type parameter"
+ collect tvs (L l (HsAppTy t1 t2 )) = do
+ tvs' <- collect tvs t2
+ collect tvs' t1
+ collect tvs (L l (HsFunTy t1 t2 )) = do
+ tvs' <- collect tvs t2
+ collect tvs' t1
+ collect tvs (L l (HsListTy t )) = collect tvs t
+ collect tvs (L l (HsPArrTy t )) = collect tvs t
+ collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
+ collect tvs (L l (HsOpTy t1 _ t2 )) = do
+ tvs' <- collect tvs t2
+ collect tvs' t1
+ collect tvs (L l (HsParTy t )) = collect tvs t
+ collect tvs (L l (HsNumTy t )) = return tvs
+ collect tvs (L l (HsPredTy t )) =
+ parseError l "Predicate not allowed as type parameter"
+ collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
+ | isRdrTyVar tv =
+ return $ L l (KindedTyVar tv k) : tvs
+ | otherwise =
+ parseError l "Kind signature only allowed for type variables"
+ collect tvs (L l (HsSpliceTy t )) =
+ parseError l "Splice not allowed as type parameter"
+
+ -- Collect all variables of a list of types
+ collects tvs [] = return tvs
+ collects tvs (t:ts) = do
+ tvs' <- collects tvs ts
+ collect tvs' t
+
+-- Check that associated type declarations of a class are all kind signatures.
+--
+checkKindSigs :: [LTyClDecl RdrName] -> P ()
+checkKindSigs = mapM_ check
+ where
+ check (L l tydecl)
+ | isFamilyDecl tydecl
+ || isSynDecl tydecl = return ()
+ | otherwise =
+ parseError l "Type declaration in a class must be a kind signature or synonym default"
+
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l t)
= check t
where
checkl (L l ty) args = check l ty args
+ check _loc (HsPredTy pred@(HsEqualP _ _))
+ args | null args
+ = return $ L spn pred
check _loc (HsTyVar t) args | not (isRdrTyVar t)
= return (L spn (HsClassP t args))
check _loc (HsAppTy l r) args = checkl l (r:args)
check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
check _loc (HsParTy t) args = checkl t args
- check loc _ _ = parseError loc "malformed class assertion"
+ check loc _ _ = parseError loc
+ "malformed class assertion"
-checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
-checkDictTy (L spn ty) = check ty []
- where
- check (HsTyVar t) args | not (isRdrTyVar t)
- = return (L spn (HsPredTy (HsClassP t args)))
- check (HsAppTy l r) args = check (unLoc l) (r:args)
- check (HsParTy t) args = check (unLoc t) args
- check _ _ = parseError spn "Malformed context in instance header"
+---------------------------------------------------------------------------
+-- Checking stand-alone deriving declarations
+
+checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
+checkDerivDecl d@(L loc _) =
+ do stDerivOn <- extension standaloneDerivingEnabled
+ if stDerivOn then return d
+ else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
---------------------------------------------------------------------------
-- Checking statements in a do-expression
-- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve
- -- NB. Negative *primitive* literals are already handled by
- -- RdrHsSyn.mkHsNegApp
+ -- NB. Negative *primitive* literals are already handled by the lexer
HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
NegApp (L _ (HsOverLit pos_lit)) _
-> return (mkNPat pos_lit (Just noSyntaxExpr))
- SectionR (L _ (HsVar bang)) e
- | bang == bang_RDR -> checkLPat e >>= (return . BangPat)
+ SectionR (L _ (HsVar bang)) e -- (! x)
+ | bang == bang_RDR
+ -> do { bang_on <- extension bangPatEnabled
+ ; if bang_on then checkLPat e >>= (return . BangPat)
+ else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
+
ELazyPat e -> checkLPat e >>= (return . LazyPat)
EAsPat n e -> checkLPat e >>= (return . AsPat n)
ExprWithTySig e t -> checkLPat e >>= \e ->
ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
return (TuplePat ps b placeHolderType)
- RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
- return (ConPatIn c (RecCon fs))
+ RecordCon c _ (HsRecFields fs dd)
+ -> mapM checkPatField fs >>= \fs ->
+ return (ConPatIn c (RecCon (HsRecFields fs dd)))
-- Generics
HsType ty -> return (TypePat ty)
_ -> patFail loc
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
- return (n,p)
+checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
+checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
+ ; return (fld { hsRecFieldArg = p }) }
patFail loc = parseError loc "Parse error in pattern"
-> Located (GRHSs RdrName)
-> P (HsBind RdrName)
+checkValDef lhs (Just sig) grhss
+ -- x :: ty = rhs parses as a *pattern* binding
+ = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
+
checkValDef lhs opt_sig grhss
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
makeFunBind fn is_infix ms
= FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
- fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
+ fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
checkPatBind lhs (L _ grhss)
= do { lhs <- checkPattern lhs
, con_qvars = qvars
, con_cxt = cxt
, con_details = PrefixCon []
- , con_res = ResTyGADT ty }
+ , con_res = ResTyGADT ty
+ , con_doc = Nothing }
-- NB: we put the whole constr type into the ResTyGADT for now;
-- the renamer will unravel it once it has sorted out
-- operator fixities
-- 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])
+-- Splits (f ! g a b) into (f, [(! g), a, b])
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
isFunLhs :: LHsExpr RdrName
-> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
-- Just (fun, is_infix, arg_pats) if e is a function LHS
+--
+-- The whole LHS is parsed as a single expression.
+-- Any infix operators on the LHS will parse left-associatively
+-- E.g. f !x y !z
+-- will parse (rather strangely) as
+-- (f ! x y) ! z
+-- It's up to isFunLhs to sort out the mess
+--
+-- a .!. !b
+
isFunLhs e = go e []
where
go (L loc (HsVar f)) es
mkRecConstrOrUpdate
:: LHsExpr RdrName
-> SrcSpan
- -> HsRecordBinds RdrName
+ -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
-> P (HsExpr RdrName)
-mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
- = return (RecordCon (L l c) noPostTcExpr fs)
-mkRecConstrOrUpdate exp loc fs@(_:_)
- = return (RecordUpd exp fs placeHolderType placeHolderType)
-mkRecConstrOrUpdate _ loc []
- = parseError loc "Empty record update"
+mkRecConstrOrUpdate (L l (HsVar c)) loc (fs,dd) | isRdrDataCon c
+ = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
+mkRecConstrOrUpdate exp loc (fs,dd)
+ | null fs = parseError loc "Empty record update"
+ | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
+
+mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
+mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
-- The Maybe is becuase the user can omit the activation spec (and usually does)
-> P (HsDecl RdrName)
mkImport (CCall cconv) safety (entity, v, ty) = do
importSpec <- parseCImport entity cconv safety v
- return (ForD (ForeignImport v ty importSpec False))
+ return (ForD (ForeignImport v ty importSpec))
mkImport (DNCall ) _ (entity, v, ty) = do
spec <- parseDImport entity
- return $ ForD (ForeignImport v ty (DNImport spec) False)
+ return $ ForD (ForeignImport v ty (DNImport spec))
-- parse the entity string of a foreign import declaration for the `ccall' or
-- `stdcall' calling convention'
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
mkExport (CCall cconv) (L loc entity, v, ty) = return $
- ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
+ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
projects / ghc-hetmet.git / blobdiff