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,
+ 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(..),
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, glaExtsEnabled, 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 )
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 ats
+mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
= ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
tcdFDs = fds,
tcdSigs = sigs,
tcdMeths = mbinds,
- tcdATs = ats
+ tcdATs = ats,
+ tcdDocs = docs
}
mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
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
---
+-- Declaration list may only contain value bindings and signatures.
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
= case cvBindsAndSigs binding of
- (mbs, sigs, []) -> -- list of type decls *always* empty
+ (mbs, sigs, [], _) -> -- list of type decls *always* empty
ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
- -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl 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
+-- 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, ts)
- where (bs, ss, ts) = go ds
- go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
+ 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) = go ds'
- go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
- where (bs, ss, ts) = go 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
= 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))
+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
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 equation of a type function and return
--- all patterns. If yes, we return 'Nothing' as the third component to
--- indicate a vanilla type synonym.
+-- 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?
-- 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]
where
gol (L l ty) acc = go l ty acc
- go l (HsTyVar tc) acc
- | not (isRdrTyVar tc) = do
- tvs <- extractTyVars acc
- return (L l tc, tvs, acc)
- go l (HsOpTy t1 tc t2) acc = do
- tvs <- extractTyVars (t1:t2:acc)
- return (tc, tvs, acc)
+ 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 head of type or 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 ()
+ -- 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"
checkKindSigs = mapM_ check
where
check (L l tydecl)
- | isKindSigDecl tydecl
+ | isFamilyDecl tydecl
|| isSynDecl tydecl = return ()
| otherwise =
parseError l "Type declaration in a class must be a kind signature or synonym default"
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"
-
-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"
-
+ check loc _ _ = parseError loc
+ "malformed class assertion"
---------------------------------------------------------------------------
-- Checking stand-alone deriving declarations
checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
checkDerivDecl d@(L loc _) =
- do glaExtOn <- extension glaExtsEnabled
- if glaExtOn then return d
- else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
+ 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))
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"
-- 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 = idHsWrapper, 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)
projects / ghc-hetmet.git / blobdiff