X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=47abf232e23181fe556aa754bd1052d9dc5b8862;hp=51b77bc13de07af3f9f8123812bd81c0eb8cdf5c;hb=5289f5d85610f71625a439747a09384876655eb5;hpb=e5b79a6988880d8757634683eefe2f03e45cdfc6 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 51b77bc..47abf23 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -10,25 +10,20 @@ module RdrHsSyn ( mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, - mkHsDo, mkHsSplice, + mkHsDo, mkHsSplice, mkTopSpliceDecl, mkClassDecl, mkTyData, mkTyFamily, mkTySynonym, - splitCon, mkInlineSpec, + splitCon, mkInlinePragma, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp cvBindGroup, cvBindsAndSigs, cvTopDecls, - findSplice, checkDecBrGroup, + placeHolderPunRhs, -- Stuff to do with Foreign declarations - CallConv(..), - mkImport, -- CallConv -> Safety - -- -> (FastString, RdrName, RdrNameHsType) - -- -> P RdrNameHsDecl + mkImport, parseCImport, - mkExport, -- CallConv - -- -> (FastString, RdrName, RdrNameHsType) - -- -> P RdrNameHsDecl + mkExport, mkExtName, -- RdrName -> CLabelString mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName mkSimpleConDecl, @@ -42,7 +37,6 @@ module RdrHsSyn ( checkTyVars, -- [LHsType RdrName] -> P () 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] @@ -50,6 +44,7 @@ module RdrHsSyn ( checkMDo, -- [Stmt] -> P [Stmt] checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + checkDoAndIfThenElse, parseError, parseErrorSDoc, ) where @@ -58,30 +53,28 @@ import HsSyn -- Lots of it import Class ( FunDep ) import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, - isRdrDataCon, isUnqual, getRdrName, isQual, - setRdrNameSpace, showRdrName ) -import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo, - InlinePragma(..), InlineSpec(..), - alwaysInlineSpec, neverInlineSpec ) + 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 Maybes import Control.Applicative ((<$>)) +import Control.Monad import Text.ParserCombinators.ReadP as ReadP import Data.List ( nubBy ) -import Data.Char ( isAscii, isAlphaNum, isAlpha ) +import Data.Char #include "HsVersions.h" \end{code} @@ -134,8 +127,10 @@ extract_lty (L loc ty) 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 _ -> acc - HsSpliceTy _ -> acc -- Type splices mention no type variables + 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) $ @@ -180,13 +175,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 @@ -197,14 +193,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, @@ -230,6 +228,17 @@ 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} %************************************************************************ @@ -262,7 +271,7 @@ cvBindGroup binding ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl 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. They might also contain Haddock comments. @@ -327,80 +336,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} @@ -429,7 +364,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 @@ -542,11 +477,13 @@ checkInstType (L l t) 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 (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 _ _ = parseError spn "Malformed instance header" + 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] @@ -571,8 +508,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] @@ -587,9 +523,20 @@ 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)) - chk (L l _) = - parseError l "Type found where type variable expected" + | 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) @@ -610,7 +557,7 @@ checkTyClHdr ty | 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 _ _ = parseError l "Malformed head of type or class declaration" + 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. -- @@ -621,7 +568,7 @@ checkKindSigs = mapM_ check | 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) @@ -661,17 +608,8 @@ checkPred (L spn ty) 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" - ---------------------------------------------------------------------------- --- 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)" + check loc _ _ = parseErrorSDoc loc + (text "malformed class assertion:" <+> ppr ty) --------------------------------------------------------------------------- -- Checking statements in a do-expression @@ -687,14 +625,16 @@ checkDo = checkDoMDo "a " "'do'" checkMDo = checkDoMDo "an " "'mdo'" checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) -checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct") +checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct")) checkDoMDo pre nm _ ss = do check ss where check [] = panic "RdrHsSyn:checkDoMDo" check [L _ (ExprStmt e _ _)] = return ([], e) - check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++ - " construct must be an expression") + 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') @@ -729,16 +669,14 @@ checkPat loc (L _ e) [] = do { pState <- getPState ; p <- checkAPat (dflags pState) loc e ; return (L loc p) } -checkPat loc _ _ - = patFail loc +checkPat loc e _ + = patFail loc (unLoc e) checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName) -checkAPat dynflags 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) +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 @@ -751,7 +689,7 @@ checkAPat dynflags 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 -XBangPatterns)" } + 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) @@ -769,7 +707,7 @@ checkAPat dynflags loc e = case e of -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) - | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR) + | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR) -> return (mkNPlusKPat (L nloc n) lit) OpApp l op _fix r -> do l <- checkLPat l @@ -777,7 +715,7 @@ checkAPat dynflags loc e = case e of case op of L cl (HsVar c) | isDataOcc (rdrNameOcc c) -> return (ConPatIn (L cl c) (InfixCon l r)) - _ -> patFail loc + _ -> patFail loc e0 HsPar e -> checkLPat e >>= (return . ParPat) ExplicitList _ es -> do ps <- mapM checkLPat es @@ -788,7 +726,7 @@ checkAPat dynflags loc e = case e of ExplicitTuple es b | all tupArgPresent es -> do ps <- mapM checkLPat [e | Present e <- es] return (TuplePat ps b placeHolderType) - | otherwise -> parseError loc "Illegal tuple section in pattern" + | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) RecordCon c _ (HsRecFields fs dd) -> do fs <- mapM checkPatField fs @@ -796,18 +734,24 @@ checkAPat dynflags loc e = case e of HsQuasiQuoteE q -> return (QuasiQuotePat q) -- Generics HsType ty -> return (TypePat ty) - _ -> patFail loc + _ -> patFail loc e0 -plus_RDR, bang_RDR :: 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 = noLoc (HsVar pun_RDR) + +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 :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName)) checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld) ; return (fld { hsRecFieldArg = p }) } -patFail :: SrcSpan -> P a -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) --------------------------------------------------------------------------- @@ -837,10 +781,6 @@ checkFunBind :: SrcSpan -> Located (GRHSs RdrName) -> P (HsBind RdrName) checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) - | isQual (unLoc fun) - = parseErrorSDoc (getLoc fun) - (ptext (sLit "Qualified name in function definition:") <+> ppr (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)]) @@ -867,8 +807,43 @@ checkValSig checkValSig (L l (HsVar v)) ty | isUnqual v && not (isDataOcc (rdrNameOcc v)) = return (TypeSig (L l v) ty) -checkValSig (L l _) _ - = parseError l "Invalid type signature" +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} @@ -943,7 +918,8 @@ 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 @@ -954,47 +930,47 @@ mkRecConstrOrUpdate 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 = parseError loc "Empty record update" + | 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) } -mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec --- The Maybe is becuase the user can omit the activation spec (and usually does) -mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info - -- INLINE -mkInlineSpec Nothing match_info False = neverInlineSpec match_info - -- NOINLINE -mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl +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 (L loc entity, v, ty) +mkImport cconv safety (L loc entity, v, ty) | cconv == PrimCallConv = do - let funcTarget = CFunction (StaticTarget entity) + let funcTarget = CFunction (StaticTarget entity Nothing) importSpec = CImport PrimCallConv safety nilFS funcTarget return (ForD (ForeignImport v ty importSpec)) + | otherwise = do case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of - Nothing -> parseError loc "Malformed entity string" + Nothing -> parseErrorSDoc loc (text "Malformed entity string") Just importSpec -> return (ForD (ForeignImport v ty importSpec)) -mkImport (DNCall ) _ (entity, v, ty) = do - spec <- parseDImport entity - return $ ForD (ForeignImport v ty (DNImport spec)) -- 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 @@ -1005,21 +981,27 @@ parseCImport cconv safety nm str = listToMaybe $ map fst $ filter (null.snd) $ readP_to_S parse str where - parse = choice [ + 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 = isAscii c && (isAlphaNum c || c `elem` "._") + 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) - +++ ((CFunction . StaticTarget) <$> cid) + +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid) where cid = return nm +++ (do c <- satisfy (\c -> isAlpha c || c == '_') @@ -1027,56 +1009,16 @@ parseCImport cconv safety nm str = return (mkFastString (c:cs))) --- --- Unravel a dotnet spec string. --- -parseDImport :: Located FastString -> P DNCallSpec -parseDImport (L loc entity) = parse0 comps - 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 - _ -> d'oh - 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" - -- construct a foreign export declaration -- -mkExport :: CallConv +mkExport :: CCallConv -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkExport (CCall cconv) (L _ 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 _ _, v, _) = - 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