X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=f03a50e6c5be714b696ef590ac74829fffb635d7;hp=200ea576a0ad834d9688e1b13f436bf54b5b729b;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=654a1ba16e47d3ddabeb74b809ee6097c0770d35 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 200ea57..f03a50e 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -4,12 +4,19 @@ 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 @@ -17,7 +24,7 @@ module RdrHsSyn ( cvBindGroup, cvBindsAndSigs, cvTopDecls, - findSplice, mkGroup, + findSplice, checkDecBrGroup, -- Stuff to do with Foreign declarations CallConv(..), @@ -54,11 +61,11 @@ module RdrHsSyn ( #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 ) @@ -69,7 +76,6 @@ import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable import FastString -import Panic import List ( isSuffixOf, nubBy ) import Monad ( unless ) @@ -173,18 +179,6 @@ 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.} @@ -215,21 +209,21 @@ cvBindGroup binding ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity RdrName]) + -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName]) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also -- associated type declarations. They might also contain Haddock comments. cvBindsAndSigs fb = go (fromOL fb) where go [] = (emptyBag, [], [], []) - go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs) + 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, add_doc x docs) + go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, docs) where (b', ds') = getMonoBind (L l b) ds (bs, ss, ts, docs) = go ds' go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs) where (bs, ss, ts, docs) = go ds - go (L _ (DocD d) : ds) = (bs, ss, ts, DocEntity d : docs) + go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs) where (bs, ss, ts, docs) = go ds ----------------------------------------------------------------------------- @@ -281,14 +275,15 @@ has_args ((L _ (Match args _ _)) : _) = not (null args) 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 @@ -304,28 +299,23 @@ add :: HsGroup a -> SrcSpan -> HsDecl 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, hs_docs = docs}) - l decl@(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, - hs_docs = add_doc decl docs}) ds - | isIdxTyDecl d = - addl (gp { hs_tyclds = L l d : ts }) ds + addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds | otherwise = - addl (gp { hs_tyclds = L l d : ts, - hs_docs = add_doc decl docs }) ds + 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, hs_docs = docs}) l x@(SigD d) ds - = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) 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, hs_docs = docs}) l x@(ValD d) ds - = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) ds +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 @@ -334,20 +324,16 @@ 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, hs_docs = docs}) l x@(ForD d) ds - = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) 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 = DocEntity d : (hs_docs gp) }) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds -add_doc decl docs = case getMainDeclBinder decl of - Just name -> DeclEntity name : docs - Nothing -> docs - add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) \end{code} @@ -369,7 +355,7 @@ add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) -- 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 @@ -380,10 +366,10 @@ mkPrefixCon ty tys mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] -> - P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) + P (Located RdrName, HsConDeclDetails RdrName) mkRecCon (L loc con) fields = do data_con <- tyConToDataCon loc con - return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- 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 @@ -434,9 +420,9 @@ checkTyVars tparms = mapM_ chk tparms 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? @@ -463,6 +449,7 @@ checkTyClHdr :: LHsContext RdrName -> LHsType RdrName -- 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] @@ -475,13 +462,12 @@ checkTyClHdr (L l cxt) ty 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 = @@ -548,7 +534,7 @@ 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" @@ -599,9 +585,9 @@ checkPred (L spn ty) 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 @@ -666,8 +652,7 @@ checkAPat loc e = case e of -- 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)) @@ -712,8 +697,9 @@ checkAPat loc e = case e of 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 (map (uncurry mkRecField) 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 @@ -722,10 +708,9 @@ plus_RDR, bang_RDR :: RdrName 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" @@ -804,7 +789,7 @@ mk_gadt_con name qvars cxt ty -- 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 @@ -816,6 +801,16 @@ splitBang other = Nothing 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 @@ -865,15 +860,17 @@ checkPrecP (L l 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" +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)