X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=ed11fd8074a6e45f7e397656c94d27a04f2ba38c;hp=14ccd2765387ed1a6a1eaa079aef65d7f0c8a054;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=ac9c1e5de9629103a125e0515dcee2466ff898a7 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 14ccd27..ed11fd8 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -8,69 +8,75 @@ module RdrHsSyn ( extractHsTyRdrTyVars, extractHsRhoRdrTyVars, extractGenericPatTyVars, - mkHsOpApp, mkClassDecl, - mkHsNegApp, mkHsIntegral, mkHsFractional, - mkHsDo, mkHsSplice, - mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, + mkHsOpApp, + mkHsIntegral, mkHsFractional, mkHsIsString, + mkHsDo, mkHsSplice, mkTopSpliceDecl, + mkClassDecl, mkTyData, mkTyFamily, mkTySynonym, + splitCon, mkInlinePragma, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp cvBindGroup, - cvBindsAndSigs, + cvBindsAndSigs, cvTopDecls, - findSplice, mkGroup, + placeHolderPunRhs, -- Stuff to do with Foreign declarations - CallConv(..), - mkImport, -- CallConv -> Safety - -- -> (FastString, RdrName, RdrNameHsType) - -- -> P RdrNameHsDecl - mkExport, -- CallConv - -- -> (FastString, RdrName, RdrNameHsType) - -- -> P RdrNameHsDecl + mkImport, + parseCImport, + mkExport, mkExtName, -- RdrName -> CLabelString - mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName - + mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName + mkSimpleConDecl, + mkDeprecatedGadtRecordDecl, + -- Bunch of functions in the parser monad for -- checking and constructing values checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkPred, -- HsType -> P HsPred - 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 checkPattern, -- HsExp -> P HsPat + bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] checkDo, -- [Stmt] -> P [Stmt] checkMDo, -- [Stmt] -> P [Stmt] checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl - parseError, -- String -> Pa + checkDoAndIfThenElse, + parseError, + parseErrorSDoc, ) where -#include "HsVersions.h" - import HsSyn -- Lots of it -import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, - isRdrDataCon, isUnqual, getRdrName, isQual, - setRdrNameSpace ) -import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec ) -import Lexer ( P, failSpanMsgP, extension, bangPatEnabled ) +import Class ( FunDep ) +import TypeRep ( Kind ) +import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, + isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) +import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, + InlinePragma(..), InlineSpec(..) ) +import Lexer import TysWiredIn ( unitTyCon ) -import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), - DNCallSpec(..), DNKind(..), CLabelString ) +import ForeignCall import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) +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 Panic +import Maybes -import List ( isSuffixOf, nubBy ) -import Monad ( unless ) +import Control.Applicative ((<$>)) +import Control.Monad +import Text.ParserCombinators.ReadP as ReadP +import Data.List ( nubBy ) +import Data.Char + +#include "HsVersions.h" \end{code} @@ -87,37 +93,52 @@ It's used when making the for-alls explicit. extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName] extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty []) +extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName] +extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty []) + extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName] -- This one takes the context and tau-part of a -- sigma type and returns their free type variables extractHsRhoRdrTyVars ctxt ty = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty []) +extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName] 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 :: HsPred RdrName -> [Located RdrName] -> [Located RdrName] +extract_pred (HsClassP _ tys) acc = extract_ltys tys acc +extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) +extract_pred (HsIParam _ ty ) acc = extract_lty ty acc + +extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName] +extract_ltys tys acc = foldr extract_lty acc tys +extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName] extract_lty (L loc ty) acc = case ty of HsTyVar tv -> extract_tv loc tv acc HsBangTy _ ty -> extract_lty ty acc + HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) HsListTy ty -> extract_lty ty acc HsPArrTy ty -> extract_lty ty acc - HsTupleTy _ tys -> foldr extract_lty acc tys + HsModalBoxType ecn ty -> extract_lty ty acc + HsTupleTy _ tys -> extract_ltys tys acc HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) HsPredTy p -> extract_pred p 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 num -> acc - HsSpliceTy _ -> acc -- Type splices mention no type variables - HsKindSig ty k -> extract_lty ty acc - HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc) - HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $ + HsNumTy {} -> acc + HsCoreTy {} -> acc -- The type is closed + HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables + HsSpliceTy {} -> 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) $ extract_lctxt cx (extract_lty ty [])) where locals = hsLTyVarNames tvs + HsDocTy ty _ -> extract_lty ty acc extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName] extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc @@ -130,10 +151,10 @@ extractGenericPatTyVars binds = nubBy eqLocated (foldrBag get [] binds) where get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms - get other acc = acc + get _ acc = acc get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc - get_m other acc = acc + get_m _ acc = acc \end{code} @@ -154,30 +175,71 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. *** See "THE NAMING STORY" in HsDecls **** \begin{code} -mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats - = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars, - tcdFDs = fds, - tcdSigs = sigs, - tcdMeths = mbinds, - tcdATs = ats - } - -mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv - = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname, - 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 +mkClassDecl :: SrcSpan + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) + -> Located [Located (FunDep RdrName)] + -> Located (OrdList (LHsDecl RdrName)) + -> P (LTyClDecl RdrName) + +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 + ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars, + tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds, + tcdATs = ats, tcdDocs = docs })) } + +mkTyData :: SrcSpan + -> NewOrData + -> Bool -- True <=> data family instance + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) + -> Maybe Kind + -> [LConDecl RdrName] + -> Maybe [LHsType RdrName] + -> P (LTyClDecl RdrName) +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, + tcdCons = data_cons, + tcdKindSig = ksig, tcdDerivs = maybe_deriv })) } + +mkTySynonym :: SrcSpan + -> Bool -- True <=> type family instances + -> LHsType RdrName -- LHS + -> LHsType RdrName -- RHS + -> P (LTyClDecl RdrName) +mkTySynonym loc is_family lhs rhs + = do { (tc, tparams) <- checkTyClHdr lhs + ; (tyvars, typats) <- checkTParams is_family tparams + ; return (L loc (TySynonym tc tyvars typats rhs)) } + +mkTyFamily :: SrcSpan + -> FamilyFlavour + -> LHsType RdrName -- LHS + -> Maybe Kind -- Optional kind signature + -> P (LTyClDecl RdrName) +mkTyFamily loc flavour lhs ksig + = do { (tc, tparams) <- checkTyClHdr lhs + ; tyvars <- checkTyVars tparams + ; return (L loc (TyFamily flavour tc tyvars ksig)) } + +mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName +-- If the user wrote +-- [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} %************************************************************************ @@ -202,29 +264,31 @@ cvTopDecls decls = go (fromOL decls) 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 - ValBindsIn mbs sigs + (mbs, sigs, tydecls, _) -> ASSERT( null tydecls ) + ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName]) + -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl]) -- 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) - 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 + go [] = (emptyBag, [], [], []) + go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs) + where (bs, ss, ts, docs) = go ds + go (L l (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 + go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d) ----------------------------------------------------------------------------- -- Group function bindings into equation groups @@ -239,24 +303,33 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -- 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 +getMonoBind (L loc1 (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) +has_args :: [LMatch RdrName] -> Bool +has_args [] = panic "RdrHsSyn:has_args" has_args ((L _ (Match args _ _)) : _) = not (null args) -- Don't group together FunBinds if they have -- no arguments. This is necessary now that variable bindings @@ -264,66 +337,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 - -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" - -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 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 - | 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_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_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_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs -add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) -\end{code} - %************************************************************************ %* * \subsection[PrefixToHS-utils]{Utilities for conversion} @@ -333,36 +346,120 @@ add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) \begin{code} ----------------------------------------------------------------------------- --- mkPrefixCon +-- splitCon -- When parsing data declarations, we sometimes inadvertently parse -- a constructor application as a type (eg. in data T a b = C a b `D` E a b) -- This function splits up the type application, adds any pending -- arguments, and converts the type constructor back into a data constructor. -mkPrefixCon :: LHsType RdrName -> [LBangType RdrName] - -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) -mkPrefixCon ty tys - = split ty tys +splitCon :: LHsType RdrName + -> P (Located RdrName, HsConDeclDetails RdrName) +-- This gets given a "type" that should look like +-- C Int Bool +-- or C { x::Int, y::Bool } +-- and returns the pieces +splitCon ty + = split ty [] where 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, 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 (L loc con) fields - = do data_con <- tyConToDataCon loc con - return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ]) + return (data_con, mk_rest ts) + 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 + +mkDeprecatedGadtRecordDecl :: SrcSpan + -> Located RdrName + -> [ConDeclField RdrName] + -> LHsType RdrName + -> P (LConDecl RdrName) +-- This one uses the deprecated syntax +-- C { x,y ::Int } :: T a b +-- We give it a RecCon details right away +mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty + = do { data_con <- tyConToDataCon con_loc con + ; return (L loc (ConDecl { con_old_rec = True + , con_name = data_con + , con_explicit = Implicit + , con_qvars = [] + , con_cxt = noLoc [] + , con_details = RecCon flds + , con_res = ResTyGADT res_ty + , con_doc = Nothing })) } + +mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName] + -> LHsContext RdrName -> HsConDeclDetails RdrName + -> ConDecl RdrName + +mkSimpleConDecl name qvars cxt details + = ConDecl { con_old_rec = False + , con_name = name + , con_explicit = Explicit + , con_qvars = qvars + , con_cxt = cxt + , con_details = details + , con_res = ResTyH98 + , con_doc = Nothing } + +mkGadtDecl :: [Located RdrName] + -> LHsType RdrName -- Always a HsForAllTy + -> [ConDecl RdrName] +-- We allow C,D :: ty +-- and expand it as if it had been +-- C :: ty; D :: ty +-- (Just like type signatures in general.) +mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau)) + = [mk_gadt_con name | name <- names] + where + (details, res_ty) -- See Note [Sorting out the result type] + = case tau of + L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty) + _other -> (PrefixCon [], tau) + + mk_gadt_con name + = ConDecl { con_old_rec = False + , con_name = name + , con_explicit = imp + , con_qvars = qvars + , con_cxt = cxt + , con_details = details + , con_res = ResTyGADT res_ty + , con_doc = Nothing } +mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty) tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) tyConToDataCon loc tc | isTcOcc (rdrNameOcc tc) = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise - = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) + = parseErrorSDoc loc (msg $$ extra) + where + msg = text "Not a data constructor:" <+> quotes (ppr tc) + extra | tc == forall_tv_RDR + = text "Perhaps you intended to use -XExistentialQuantification" + | otherwise = empty +\end{code} + +Note [Sorting out the result type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a GADT declaration which is not a record, we put the whole constr +type into the ResTyGADT for now; the renamer will unravel it once it +has sorted out operator fixities. Consider for example + C :: a :*: b -> a :*: b -> a :+: b +Initially this type will parse as + a :*: (b -> (a :*: (b -> (a :+: b)))) + +so it's hard to split up the arguments until we've done the precedence +resolution (in the renamer) On the other hand, for a record + { x,y :: Int } -> a :*: b +there is no doubt. AND we need to sort records out so that +we can bring x,y into scope. So: + * For PrefixCon we keep all the args in the ResTyGADT + * For RecCon we do not +\begin{code} ---------------------------------------------------------------------------- -- Various Syntactic Checks @@ -378,129 +475,90 @@ checkInstType (L l t) 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 tc) args | isRdrTc tc = done tc args + check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args) + check (HsAppTy l r) args = check (unLoc l) (r:args) + check (HsParTy t) args = check (unLoc t) args + check _ _ = parseErrorSDoc spn (text "Malformed instance header:" <+> ppr ty) + + done tc args = return (L spn (HsPredTy (HsClassP tc args))) + +checkTParams :: Bool -- Type/data family + -> [LHsType RdrName] + -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName]) +-- checkTParams checks the type parameters of a data/newtype declaration +-- There are two cases: +-- +-- a) Vanilla data/newtype decl. In that case +-- - the type parameters should all be type variables +-- - they may have a kind annotation +-- +-- b) Family data/newtype decl. In that case +-- - The type parameters may be arbitrary types +-- - We find the type-varaible binders by find the +-- free type vars of those types +-- - We make them all kind-sig-free binders (UserTyVar) +-- If there are kind sigs in the type parameters, they +-- will fix the binder's kind when we kind-check the +-- type parameters +checkTParams is_family tparams + | not is_family -- Vanilla case (a) + = do { tyvars <- checkTyVars tparams + ; return (tyvars, Nothing) } + | otherwise -- Family case (b) + = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams) + ; return (tyvars, Just tparams) } + +checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName] -- 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 +checkTyVars tparms = mapM chk tparms where -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return () + | isRdrTyVar tv = return (L l (KindedTyVar tv k)) chk (L l (HsTyVar tv)) - | 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 equation of a type function 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) } - - + | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) + chk t@(L l _) = + parseErrorSDoc l (text "Type found:" <+> ppr t + $$ text "where type variable expected, in:" <+> + sep (map (pprParendHsType . unLoc) tparms)) + +checkDatatypeContext :: Maybe (LHsContext RdrName) -> P () +checkDatatypeContext Nothing = return () +checkDatatypeContext (Just (L loc c)) + = do allowed <- extension datatypeContextsEnabled + unless allowed $ + parseErrorSDoc loc + (text "Illegal datatype context (use -XDatatypeContexts):" <+> + pprHsContext c) + +checkTyClHdr :: LHsType RdrName + -> P (Located RdrName, -- the head symbol (type or class name) + [LHsType RdrName]) -- parameters of head symbol -- Well-formedness check and decomposition of type and class heads. --- -checkTyClHdr :: LHsContext RdrName -> LHsType 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] --- 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, parms) <- gol ty [] - mapM_ chk_pred cxt - 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) = 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 (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 () - 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 +-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) +-- Int :*: Bool into (:*:, [Int, Bool]) +-- returning the pieces +checkTyClHdr ty + = goL ty [] 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 + goL (L l ty) acc = go l ty acc + + go l (HsTyVar tc) acc + | isRdrTc tc = return (L l tc, acc) + + go _ (HsOpTy t1 ltc@(L _ tc) t2) acc + | isRdrTc tc = return (ltc, t1:t2:acc) + go _ (HsParTy ty) acc = goL ty acc + go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc) + go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) -- Check that associated type declarations of a class are all kind signatures. -- @@ -508,10 +566,10 @@ checkKindSigs :: [LTyClDecl RdrName] -> P () 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" + parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" $$ ppr tydecl) checkContext :: LHsType RdrName -> P (LHsContext RdrName) checkContext (L l t) @@ -543,21 +601,16 @@ checkPred (L spn ty) 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 _ _ = parseErrorSDoc loc + (text "malformed class assertion:" <+> ppr ty) --------------------------------------------------------------------------- -- Checking statements in a do-expression @@ -567,17 +620,22 @@ checkDictTy (L spn ty) = check ty [] -- (b) returns it separately -- same comments apply for mdo as well +checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) + checkDo = checkDoMDo "a " "'do'" checkMDo = checkDoMDo "an " "'mdo'" checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) -checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct") -checkDoMDo pre nm loc ss = do +checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct")) +checkDoMDo pre nm _ ss = do check ss where - check [L l (ExprStmt e _ _)] = return ([], e) - check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++ - " construct must be an expression") + check [] = panic "RdrHsSyn:checkDoMDo" + check [L _ (ExprStmt e _ _)] = return ([], e) + check [L l e] = parseErrorSDoc l + (text ("The last statement in " ++ pre ++ nm ++ + " construct must be an expression:") + $$ ppr e) check (s:ss) = do (ss',e') <- check ss return ((s:ss'),e') @@ -609,22 +667,22 @@ checkPat loc e args -- OK to let this happen even if bang-patterns 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 - -checkAPat loc e = case e of - EWildPat -> return (WildPat placeHolderType) - HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: " - ++ showRdrName x) - | otherwise -> return (VarPat x) - HsLit l -> return (LitPat l) + = do { pState <- getPState + ; p <- checkAPat (dflags pState) loc e + ; return (L loc p) } +checkPat loc e _ + = patFail loc (unLoc e) + +checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName) +checkAPat dynflags loc e0 = case e0 of + EWildPat -> return (WildPat placeHolderType) + HsVar x -> return (VarPat x) + HsLit l -> return (LitPat l) -- 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 - HsOverLit pos_lit -> return (mkNPat pos_lit Nothing) + -- 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)) @@ -632,58 +690,69 @@ checkAPat loc e = case e of | 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)" } + else parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) } 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 - -- we have to remove the implicit forall here. - let t' = case t of - L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty - other -> other - in - return (SigPatIn e t') + -- view pattern is well-formed if the pattern is + EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType)) + ExprWithTySig e t -> do e <- checkLPat e + -- Pattern signatures are parsed as sigtypes, + -- but they aren't explicit forall points. Hence + -- we have to remove the implicit forall here. + let t' = case t of + L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty + other -> other + return (SigPatIn e t') -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ - (L _ (HsOverLit lit@(HsIntegral _ _))) - | plus == plus_RDR + (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) + | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR) -> return (mkNPlusKPat (L nloc n) lit) - OpApp l op fix r -> checkLPat l >>= \l -> - checkLPat r >>= \r -> - case op of - L cl (HsVar c) | isDataOcc (rdrNameOcc c) - -> return (ConPatIn (L cl c) (InfixCon l r)) - _ -> patFail loc + OpApp l op _fix r -> do l <- checkLPat l + r <- checkLPat r + case op of + L cl (HsVar c) | isDataOcc (rdrNameOcc c) + -> return (ConPatIn (L cl c) (InfixCon l r)) + _ -> patFail loc e0 - HsPar e -> checkLPat e >>= (return . ParPat) - ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps -> - return (ListPat ps placeHolderType) - ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps -> - return (PArrPat ps placeHolderType) + HsPar e -> checkLPat e >>= (return . ParPat) + ExplicitList _ es -> do ps <- mapM checkLPat es + return (ListPat ps placeHolderType) + ExplicitPArr _ es -> do ps <- mapM checkLPat es + return (PArrPat ps placeHolderType) - ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps -> - return (TuplePat ps b placeHolderType) + ExplicitTuple es b + | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es] + return (TuplePat ps b placeHolderType) + | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) - RecordCon c _ fs -> mapM checkPatField fs >>= \fs -> - return (ConPatIn c (RecCon fs)) + RecordCon c _ (HsRecFields fs dd) + -> do fs <- mapM checkPatField fs + return (ConPatIn c (RecCon (HsRecFields fs dd))) + HsQuasiQuoteE q -> return (QuasiQuotePat q) -- Generics HsType ty -> return (TypePat ty) - _ -> patFail loc + _ -> patFail loc e0 + +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 = noLoc (HsVar pun_RDR) -plus_RDR, bang_RDR :: RdrName -plus_RDR = mkUnqual varName FSLIT("+") -- Hack -bang_RDR = mkUnqual varName FSLIT("!") -- Hack +plus_RDR, bang_RDR, pun_RDR :: RdrName +plus_RDR = mkUnqual varName (fsLit "+") -- Hack +bang_RDR = mkUnqual varName (fsLit "!") -- Hack +pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") -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" +patFail :: SrcSpan -> HsExpr RdrName -> P a +patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e) --------------------------------------------------------------------------- @@ -705,11 +774,14 @@ checkValDef lhs opt_sig grhss fun is_infix pats opt_sig grhss Nothing -> checkPatBind lhs grhss } +checkFunBind :: SrcSpan + -> Located RdrName + -> Bool + -> [LHsExpr RdrName] + -> Maybe (LHsType RdrName) + -> Located (GRHSs RdrName) + -> P (HsBind RdrName) 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 return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)]) @@ -720,8 +792,11 @@ makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id -- 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 :: LHsExpr RdrName + -> Located (GRHSs RdrName) + -> P (HsBind RdrName) checkPatBind lhs (L _ grhss) = do { lhs <- checkPattern lhs ; return (PatBind lhs grhss placeHolderType placeHolderNames) } @@ -730,47 +805,78 @@ checkValSig :: LHsExpr RdrName -> LHsType RdrName -> P (Sig RdrName) +checkValSig (L l (HsHetMetBrak _ e)) ty + = checkValSig e ty checkValSig (L l (HsVar v)) ty | isUnqual v && not (isDataOcc (rdrNameOcc v)) = return (TypeSig (L l v) ty) -checkValSig (L l other) ty - = parseError l "Invalid type signature" - -mkGadtDecl :: Located RdrName - -> LHsType RdrName -- assuming HsType - -> ConDecl RdrName -mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty -mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty - -mk_gadt_con name qvars cxt ty - = ConDecl { con_name = name - , con_explicit = Implicit - , con_qvars = qvars - , con_cxt = cxt - , con_details = PrefixCon [] - , con_res = ResTyGADT ty } - -- NB: we put the whole constr type into the ResTyGADT for now; - -- the renamer will unravel it once it has sorted out - -- operator fixities - --- A variable binding is parsed as a FunBind. +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 + looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR + looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs + looks_like_foreign _ = False + + foreign_RDR = mkUnqual varName (fsLit "foreign") + +checkDoAndIfThenElse :: LHsExpr RdrName + -> Bool + -> LHsExpr RdrName + -> Bool + -> LHsExpr RdrName + -> P () +checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr + | semiThen || semiElse + = do pState <- getPState + unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do + parseErrorSDoc (combineLocs guardExpr elseExpr) + (text "Unexpected semi-colons in conditional:" + $$ nest 4 expr + $$ text "Perhaps you meant to use -XDoAndIfThenElse?") + | otherwise = return () + where pprOptSemi True = semi + pprOptSemi False = empty + expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> + text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> + text "else" <+> ppr elseExpr +\end{code} +\begin{code} -- 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)) +-- Splits (f ! g a b) into (f, [(! g), a, b]) +splitBang (L loc (OpApp l_arg bang@(L _ (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 +splitBang _ = Nothing isFunLhs :: LHsExpr RdrName -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName])) +-- A variable binding is parsed as a FunBind. -- 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 @@ -815,155 +921,107 @@ isFunLhs e = go e [] checkPrecP :: Located Int -> P Int checkPrecP (L l i) | 0 <= i && i <= maxPrecedence = return i - | otherwise = parseError l "Precedence out of range" + | otherwise + = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) 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" - -mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec --- The Maybe is becuase the user can omit the activation spec (and usually does) -mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE -mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE -mkInlineSpec (Just act) inl = Inline act inl - +mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c + = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd)) +mkRecConstrOrUpdate exp loc (fs,dd) + | null fs = parseErrorSDoc loc (text "Empty record update of:" <+> ppr exp) + | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] []) + +mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg +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) } + +mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma +-- The Maybe is because the user can omit the activation spec (and usually does) +mkInlinePragma (inl, match_info) mb_act + = InlinePragma { inl_inline = inl + , inl_sat = Nothing + , inl_act = act + , inl_rule = match_info } + where + act = case mb_act of + Just act -> act + Nothing -> -- No phase specified + case inl of + NoInline -> NeverActive + _other -> AlwaysActive ----------------------------------------------------------------------------- -- utilities for foreign declarations --- supported calling conventions --- -data CallConv = CCall CCallConv -- ccall or stdcall - | DNCall -- .NET - -- construct a foreign import declaration -- -mkImport :: CallConv +mkImport :: CCallConv -> Safety -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkImport (CCall cconv) safety (entity, v, ty) = do - importSpec <- parseCImport entity cconv safety v +mkImport cconv safety (L loc entity, v, ty) + | cconv == PrimCallConv = do + let funcTarget = CFunction (StaticTarget entity Nothing) + importSpec = CImport PrimCallConv safety nilFS funcTarget return (ForD (ForeignImport v ty importSpec)) -mkImport (DNCall ) _ (entity, v, ty) = do - spec <- parseDImport entity - return $ ForD (ForeignImport v ty (DNImport spec)) --- parse the entity string of a foreign import declaration for the `ccall' or --- `stdcall' calling convention' --- -parseCImport :: Located FastString - -> CCallConv - -> Safety - -> Located RdrName - -> P ForeignImport -parseCImport (L loc entity) cconv safety v - -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak - | entity == FSLIT ("dynamic") = - return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget) - | entity == FSLIT ("wrapper") = - return $ CImport cconv safety nilFS nilFS CWrapper - | otherwise = parse0 (unpackFS entity) - where - -- using the static keyword? - parse0 (' ': rest) = parse0 rest - parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest - parse0 rest = parse1 rest - -- check for header file name - parse1 "" = parse4 "" nilFS False nilFS - parse1 (' ':rest) = parse1 rest - parse1 str@('&':_ ) = parse2 str nilFS - parse1 str@('[':_ ) = parse3 str nilFS False - parse1 str - | ".h" `isSuffixOf` first = parse2 rest (mkFastString first) - | otherwise = parse4 str nilFS False nilFS - where - (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str - -- check for address operator (indicating a label import) - parse2 "" header = parse4 "" header False nilFS - parse2 (' ':rest) header = parse2 rest header - parse2 ('&':rest) header = parse3 rest header True - parse2 str@('[':_ ) header = parse3 str header False - parse2 str header = parse4 str header False nilFS - -- check for library object name - parse3 (' ':rest) header isLbl = parse3 rest header isLbl - parse3 ('[':rest) header isLbl = - case break (== ']') rest of - (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib) - _ -> parseError loc "Missing ']' in entity" - parse3 str header isLbl = parse4 str header isLbl nilFS - -- check for name of C function - parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib - parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib - parse4 str header isLbl lib - | all (== ' ') rest = build (mkFastString first) header isLbl lib - | otherwise = parseError loc "Malformed entity string" - where - (first, rest) = break (== ' ') str - -- - build cid header False lib = return $ - CImport cconv safety header lib (CFunction (StaticTarget cid)) - build cid header True lib = return $ - CImport cconv safety header lib (CLabel cid ) - --- --- Unravel a dotnet spec string. --- -parseDImport :: Located FastString -> P DNCallSpec -parseDImport (L loc entity) = parse0 comps + | otherwise = do + case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of + Nothing -> parseErrorSDoc loc (text "Malformed entity string") + Just importSpec -> return (ForD (ForeignImport v ty importSpec)) + +-- the string "foo" is ambigous: either a header or a C identifier. The +-- C identifier case comes first in the alternatives below, so we pick +-- that one. +parseCImport :: CCallConv -> Safety -> FastString -> String + -> Maybe ForeignImport +parseCImport cconv safety nm str = + listToMaybe $ map fst $ filter (null.snd) $ + readP_to_S parse str where - comps = words (unpackFS entity) - - parse0 [] = d'oh - parse0 (x : xs) - | x == "static" = parse1 True xs - | otherwise = parse1 False (x:xs) - - parse1 _ [] = d'oh - parse1 isStatic (x:xs) - | x == "method" = parse2 isStatic DNMethod xs - | x == "field" = parse2 isStatic DNField xs - | x == "ctor" = parse2 isStatic DNConstructor xs - parse1 isStatic xs = parse2 isStatic DNMethod xs - - parse2 _ _ [] = d'oh - parse2 isStatic kind (('[':x):xs) = - case x of - [] -> d'oh - vs | last vs == ']' -> parse3 isStatic kind (init vs) xs - parse2 isStatic kind xs = parse3 isStatic kind "" xs - - parse3 isStatic kind assem [x] = - return (DNCallSpec isStatic kind assem x - -- these will be filled in once known. - (error "FFI-dotnet-args") - (error "FFI-dotnet-result")) - parse3 _ _ _ _ = d'oh - - d'oh = parseError loc "Malformed entity string" - + parse = do + skipSpaces + r <- choice [ + string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)), + string "wrapper" >> return (mk nilFS CWrapper), + optional (string "static" >> skipSpaces) >> + (mk nilFS <$> cimp nm) +++ + (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm) + ] + skipSpaces + return r + + mk = CImport cconv safety + + hdr_char c = not (isSpace c) -- header files are filenames, which can contain + -- pretty much any char (depending on the platform), + -- so just accept any non-space character + id_char c = isAlphaNum c || c == '_' + + cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) + +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid) + where + cid = return nm +++ + (do c <- satisfy (\c -> isAlpha c || c == '_') + cs <- many (satisfy id_char) + return (mkFastString (c:cs))) + + -- construct a foreign export declaration -- -mkExport :: CallConv +mkExport :: CCallConv -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkExport (CCall cconv) (L loc entity, v, ty) = return $ +mkExport cconv (L _ entity, v, ty) = return $ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv))) where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity -mkExport DNCall (L loc entity, v, ty) = - parseError (getLoc v){-TODO: not quite right-} - "Foreign export is not yet supported for .NET" -- Supplying the ext_name in a foreign decl is optional; if it -- isn't there, the Haskell name is assumed. Note that no transformation @@ -980,9 +1038,9 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) -- Misc utils \begin{code} -showRdrName :: RdrName -> String -showRdrName r = showSDoc (ppr r) - parseError :: SrcSpan -> String -> P a -parseError span s = failSpanMsgP span s +parseError span s = parseErrorSDoc span (text s) + +parseErrorSDoc :: SrcSpan -> SDoc -> P a +parseErrorSDoc span s = failSpanMsgP span s \end{code}