X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=f03a50e6c5be714b696ef590ac74829fffb635d7;hp=96088f400d0642a6cc9dad8af32af9d512012e9f;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=b1ab4b8a607addc4d097588db5761313c996a41f diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 96088f4..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, mkHsIsString, + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkHsSplice, mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp @@ -58,7 +65,7 @@ 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 ) @@ -172,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.} @@ -360,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 @@ -371,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 @@ -425,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? @@ -454,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] @@ -471,7 +467,7 @@ checkTyClHdr (L l cxt) ty 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, 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 = @@ -589,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 @@ -656,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)) @@ -702,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 _ (HsRecordBinds 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 @@ -712,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" @@ -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@(HsRecordBinds (_:_)) - = return (RecordUpd exp fs [] [] []) -mkRecConstrOrUpdate _ loc (HsRecordBinds []) - = 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)