X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=90220d365d398e6a28b55a2e65feb5815f6f1073;hp=b86068cf0f314f453e5292a2e024fa3d36d6f8ac;hb=5e4375adca19f66803c3ad47fb1ba2c2ac6b4b62;hpb=3ddb6bb4edf70b2456d789f34d3f56541818a696 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index b86068c..90220d3 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -18,7 +18,6 @@ module RdrHsSyn ( cvBindGroup, cvBindsAndSigs, cvTopDecls, - findSplice, checkDecBrGroup, placeHolderPunRhs, -- Stuff to do with Foreign declarations @@ -65,12 +64,13 @@ import PrelNames ( forall_tv_RDR ) import DynFlags import SrcLoc import OrdList ( OrdList, fromOL ) -import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) +import Bag ( Bag, emptyBag, consBag, foldrBag ) import Outputable import FastString import Maybes import Control.Applicative ((<$>)) +import Control.Monad import Text.ParserCombinators.ReadP as ReadP import Data.List ( nubBy ) import Data.Char @@ -127,8 +127,8 @@ extract_lty (L loc ty) acc HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) HsParTy ty -> extract_lty ty acc HsNumTy _ -> acc + HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables HsSpliceTy {} -> acc -- Type splices mention no type variables - HsSpliceTyOut {} -> acc -- Type splices mention no type variables HsKindSig ty _ -> extract_lty ty acc HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc) HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $ @@ -173,13 +173,14 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. \begin{code} mkClassDecl :: SrcSpan - -> Located (LHsContext RdrName, LHsType RdrName) + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Located [Located (FunDep RdrName)] -> Located (OrdList (LHsDecl RdrName)) -> P (LTyClDecl RdrName) -mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls +mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls) + ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams) <- checkTyClHdr tycl_hdr ; tyvars <- checkTyVars tparams -- Only type vars allowed ; checkKindSigs ats @@ -190,14 +191,16 @@ mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls mkTyData :: SrcSpan -> NewOrData -> Bool -- True <=> data family instance - -> Located (LHsContext RdrName, LHsType RdrName) + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Maybe Kind -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (LTyClDecl RdrName) -mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv +mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr + ; checkDatatypeContext mcxt + ; let cxt = fromMaybe (noLoc []) mcxt ; (tyvars, typats) <- checkTParams is_family tparams ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc, tcdTyVars = tyvars, tcdTyPats = typats, @@ -226,17 +229,14 @@ mkTyFamily loc flavour lhs ksig mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName -- If the user wrote --- $(e) --- then that's the splice, but if she wrote, say, --- f x --- then behave as if she'd written --- $(f x) -mkTopSpliceDecl expr - = SpliceD (SpliceDecl expr') - where - expr' = case expr of - (L _ (HsSpliceE (HsSplice _ expr))) -> expr - _other -> expr +-- [pads| ... ] then return a QuasiQuoteD +-- $(e) then return a SpliceD +-- but if she wrote, say, +-- f x then behave as if she'd written $(f x) +-- ie a SpliceD +mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq +mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr Explicit) +mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit) \end{code} %************************************************************************ @@ -334,80 +334,6 @@ has_args ((L _ (Match args _ _)) : _) = not (null args) -- than pattern bindings (tests/rename/should_fail/rnfail002). \end{code} -\begin{code} -findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) -findSplice ds = addl emptyRdrGroup ds - -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 - --- Base cases -addl gp [] = (gp, Nothing) -addl gp (L l d : ds) = add gp l d ds - - -add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a] - -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) - -add gp _ (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 - | 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 - | otherwise = - addl (gp { hs_tyclds = L l d : ts }) ds - --- Signatures: fixity sigs go a different place than all others -add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds - = addl (gp {hs_fixds = L l f : ts}) ds -add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds - = addl (gp {hs_valds = add_sig (L l d) ts}) ds - --- Value declarations: use add_bind -add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds - = addl (gp { hs_valds = add_bind (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 - = addl (gp { hs_fords = L l d : ts }) ds -add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds - = addl (gp { hs_warnds = L l d : ts }) ds -add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds - = addl (gp { hs_annds = 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 :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs -add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" - -add_sig :: LSig a -> HsValBinds a -> HsValBinds a -add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) -add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" -\end{code} - %************************************************************************ %* * \subsection[PrefixToHS-utils]{Utilities for conversion} @@ -436,7 +362,7 @@ splitCon ty split (L _ (HsAppTy t u)) ts = split t (u : ts) split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc return (data_con, mk_rest ts) - split (L l _) _ = parseError l "parse error in data/newtype declaration" + split (L l _) _ = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty) mk_rest [L _ (HsRecTy flds)] = RecCon flds mk_rest ts = PrefixCon ts @@ -580,8 +506,7 @@ checkTParams is_family tparams = do { tyvars <- checkTyVars tparams ; return (tyvars, Nothing) } | otherwise -- Family case (b) - = do { let tyvars = [L l (UserTyVar tv) - | L l tv <- extractHsTysRdrTyVars tparams] + = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams) ; return (tyvars, Just tparams) } checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName] @@ -596,10 +521,17 @@ checkTyVars tparms = mapM chk tparms chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) | isRdrTyVar tv = return (L l (KindedTyVar tv k)) chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return (L l (UserTyVar tv)) + | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) chk (L l _) = parseError l "Type found where type variable expected" +checkDatatypeContext :: Maybe (LHsContext RdrName) -> P () +checkDatatypeContext Nothing = return () +checkDatatypeContext (Just (L loc _)) + = do allowed <- extension datatypeContextsEnabled + unless allowed $ + parseError loc "Illegal datatype context (use -XDatatypeContexts)" + checkTyClHdr :: LHsType RdrName -> P (Located RdrName, -- the head symbol (type or class name) [LHsType RdrName]) -- parameters of head symbol @@ -796,10 +728,10 @@ checkAPat dynflags loc e = case e of HsType ty -> return (TypePat ty) _ -> patFail loc -placeHolderPunRhs :: HsExpr RdrName +placeHolderPunRhs :: LHsExpr RdrName -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when debugging -placeHolderPunRhs = HsVar pun_RDR +placeHolderPunRhs = noLoc (HsVar pun_RDR) plus_RDR, bang_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack @@ -867,12 +799,14 @@ checkValSig checkValSig (L l (HsVar v)) ty | isUnqual v && not (isDataOcc (rdrNameOcc v)) = return (TypeSig (L l v) ty) -checkValSig lhs@(L l _) _ - | looks_like_foreign lhs - = parseError l "Invalid type signature; perhaps you meant to use -XForeignFunctionInterface?" - | otherwise - = parseError l "Invalid type signature: should be of form :: " +checkValSig lhs@(L l _) ty + = parseErrorSDoc l ((text "Invalid type signature:" <+> + ppr lhs <+> text "::" <+> ppr ty) + $$ text hint) where + hint = if looks_like_foreign lhs + then "Perhaps you meant to use -XForeignFunctionInterface?" + else "Should be of form :: " -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword