X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=a9557914129761cb079fa41ec8ec94821c061e3f;hb=b785be47556f5c1128e76355471fdb5de0a1ee64;hp=e94eb614553f18f00ed2181c3340e5a57d397697;hpb=766c499e75fa1aa178694dc1a74d1ecbabef0332;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index e94eb61..a955791 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -11,7 +11,7 @@ module RdrHsSyn ( mkHsOpApp, mkClassDecl, mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsDo, mkHsSplice, - mkTyData, mkPrefixCon, mkRecCon, + mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp cvBindGroup, @@ -20,45 +20,46 @@ module RdrHsSyn ( findSplice, mkGroup, -- Stuff to do with Foreign declarations - , CallConv(..) - , mkImport -- CallConv -> Safety + CallConv(..), + mkImport, -- CallConv -> Safety -- -> (FastString, RdrName, RdrNameHsType) -- -> P RdrNameHsDecl - , mkExport -- CallConv + mkExport, -- CallConv -- -> (FastString, RdrName, RdrNameHsType) -- -> P RdrNameHsDecl - , mkExtName -- RdrName -> CLabelString + mkExtName, -- RdrName -> CLabelString + mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName -- 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 - , checkSynHdr - , checkInstType -- HsType -> P HsType - , checkPattern -- HsExp -> P HsPat - , 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 + checkPrecP, -- Int -> P Int + checkContext, -- HsType -> P HsContext + checkPred, -- HsType -> P HsPred + checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) + checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName]) + checkInstType, -- HsType -> P HsType + checkPattern, -- HsExp -> P HsPat + 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 ) where #include "HsVersions.h" import HsSyn -- Lots of it import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, - isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, + isRdrDataCon, isUnqual, getRdrName, isQual, setRdrNameSpace ) -import BasicTypes ( RecFlag(..), maxPrecedence ) +import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec ) import Lexer ( P, failSpanMsgP ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..), CLabelString ) import OccName ( srcDataName, varName, isDataOcc, isTcOcc, - occNameUserString ) + occNameString ) import SrcLoc import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) @@ -89,34 +90,35 @@ extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrNa extractHsRhoRdrTyVars ctxt ty = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty []) -extract_lctxt ctxt acc = foldr (extract_pred.unLoc) acc (unLoc ctxt) +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_lty (L loc (HsTyVar tv)) acc - | isRdrTyVar tv = L loc tv : acc - | otherwise = acc -extract_lty ty acc = extract_ty (unLoc ty) acc - -extract_ty (HsBangTy _ ty) acc = extract_lty ty acc -extract_ty (HsAppTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) -extract_ty (HsListTy ty) acc = extract_lty ty acc -extract_ty (HsPArrTy ty) acc = extract_lty ty acc -extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys -extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) -extract_ty (HsPredTy p) acc = extract_pred p acc -extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc) -extract_ty (HsParTy ty) acc = extract_lty ty acc -extract_ty (HsNumTy num) acc = acc -extract_ty (HsSpliceTy _) acc = acc -- Type splices mention no type variables -extract_ty (HsKindSig ty k) acc = extract_lty ty acc -extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc) -extract_ty (HsForAllTy exp tvs cx ty) - acc = (filter ((`notElem` locals) . unLoc) $ - extract_lctxt cx (extract_lty ty [])) ++ acc - where - locals = hsLTyVarNames tvs +extract_lty (L loc ty) acc + = case ty of + HsTyVar tv -> extract_tv loc tv acc + HsBangTy _ ty -> extract_lty ty acc + 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 + 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) $ + extract_lctxt cx (extract_lty ty [])) + where + locals = hsLTyVarNames tvs + +extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName] +extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc + | otherwise = acc extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName] -- Get the type variables out of the type patterns in a bunch of @@ -124,8 +126,8 @@ extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName] extractGenericPatTyVars binds = nubBy eqLocated (foldrBag get [] binds) where - get (L _ (FunBind _ _ (MatchGroup ms _))) acc = foldr (get_m.unLoc) acc ms - get other acc = acc + get (L _ (FunBind _ _ (MatchGroup ms _) _)) acc = foldr (get_m.unLoc) acc ms + get other acc = acc get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc get_m other acc = acc @@ -156,7 +158,7 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds tcdMeths = mbinds } -mkTyData new_or_data (L _ (context, tname, tyvars)) ksig data_cons maybe_deriv +mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname, tcdTyVars = tyvars, tcdCons = data_cons, tcdKindSig = ksig, tcdDerivs = maybe_deriv } @@ -171,7 +173,7 @@ 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) placeHolderName + f expr = NegApp (L loc e) noSyntaxExpr \end{code} %************************************************************************ @@ -186,7 +188,7 @@ analyser. \begin{code} --- | Groups together bindings for a single function +-- | Groups together bindings for a single function cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName] cvTopDecls decls = go (fromOL decls) where @@ -196,10 +198,10 @@ cvTopDecls decls = go (fromOL decls) where (L l' b', ds') = getMonoBind (L l b) ds go (d : ds) = d : go ds -cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName +cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName cvBindGroup binding = case (cvBindsAndSigs binding) of { (mbs, sigs) -> - HsBindGroup mbs sigs Recursive -- just one big group for now + ValBindsIn mbs sigs } cvBindsAndSigs :: OrdList (LHsDecl RdrName) @@ -229,17 +231,16 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations --- gaw 2004 -getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds +getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _) _)) binds | has_args mtchs = go mtchs loc binds where - go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _))) : binds) + go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _) _)) : binds) | f == unLoc f2 = go (mtchs2++mtchs1) loc binds where loc = combineSrcSpans loc1 loc2 go mtchs1 loc binds - = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1))), binds) - -- reverse the final matches, to get it back in the right order + = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1)) placeHolderNames), binds) + -- Reverse the final matches, to get it back in the right order getMonoBind bind binds = (bind, binds) @@ -251,16 +252,11 @@ has_args ((L _ (Match args _ _)) : _) = not (null args) \end{code} \begin{code} -emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive], - hs_tyclds = [], hs_instds = [], - hs_fixds = [], hs_defds = [], hs_fords = [], - hs_depds = [] ,hs_ruleds = [] } - findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) -findSplice ds = addl emptyGroup ds +findSplice ds = addl emptyRdrGroup ds mkGroup :: [LHsDecl a] -> HsGroup a -mkGroup ds = addImpDecls emptyGroup ds +mkGroup ds = addImpDecls emptyRdrGroup ds addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a -- The decls are imported, and should not have a splice @@ -311,8 +307,8 @@ add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds = addl (gp { hs_ruleds = L l d : ts }) ds -add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r] -add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r] +add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs +add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) \end{code} %************************************************************************ @@ -467,23 +463,23 @@ checkDictTy (L spn ty) = check ty [] -- We parse do { e1 ; e2 ; } -- as [ExprStmt e1, ExprStmt e2] -- checkDo (a) checks that the last thing is an ExprStmt --- (b) transforms it to a ResultStmt +-- (b) returns it separately -- same comments apply for mdo as well checkDo = checkDoMDo "a " "'do'" checkMDo = checkDoMDo "an " "'mdo'" -checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName] +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 check ss where - check [L l (ExprStmt e _)] = return [L l (ResultStmt e)] + check [L l (ExprStmt e _ _)] = return ([], e) check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++ " construct must be an expression") check (s:ss) = do - ss' <- check ss - return (s:ss') + (ss',e') <- check ss + return ((s:ss'),e') -- ------------------------------------------------------------------------- -- Checking Patterns. @@ -523,9 +519,9 @@ checkAPat loc e = case e of -- 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 (NPatIn pos_lit Nothing) + HsOverLit pos_lit -> return (mkNPat pos_lit Nothing) NegApp (L _ (HsOverLit pos_lit)) _ - -> return (NPatIn pos_lit (Just placeHolderName)) + -> return (mkNPat pos_lit (Just noSyntaxExpr)) ELazyPat e -> checkLPat e >>= (return . LazyPat) EAsPat n e -> checkLPat e >>= (return . AsPat n) @@ -563,7 +559,7 @@ checkAPat loc e = case e of ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps -> return (TuplePat ps b) - RecordCon c fs -> mapM checkPatField fs >>= \fs -> + RecordCon c _ fs -> mapM checkPatField fs >>= \fs -> return (ConPatIn c (RecCon fs)) -- Generics HsType ty -> return (TypePat ty) @@ -593,20 +589,48 @@ checkValDef lhs opt_sig (L rhs_span grhss) showRdrName (unLoc f)) else do ps <- checkPatterns es let match_span = combineSrcSpans (getLoc lhs) rhs_span - return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)])) + matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)] + return (FunBind f inf matches placeHolderNames) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. | otherwise = do lhs <- checkPattern lhs - return (PatBind lhs grhss placeHolderType) + return (PatBind lhs grhss placeHolderType placeHolderNames) checkValSig :: LHsExpr RdrName -> LHsType RdrName -> P (Sig RdrName) -checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) 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 "Type signature given for an expression" + = parseError l "Invalid type signature" + +mkGadtDecl + :: Located RdrName + -> LHsType RdrName -- assuming HsType + -> ConDecl RdrName +mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = ConDecl + { con_name = name + , con_explicit = Implicit + , con_qvars = qvars + , con_cxt = cxt + , con_details = PrefixCon args + , con_res = ResTyGADT res + } + where + (args, res) = splitHsFunType ty +mkGadtDecl name ty = ConDecl + { con_name = name + , con_explicit = Implicit + , con_qvars = [] + , con_cxt = noLoc [] + , con_details = PrefixCon args + , con_res = ResTyGADT res + } + where + (args, res) = splitHsFunType ty -- A variable binding is parsed as a FunBind. @@ -643,12 +667,19 @@ mkRecConstrOrUpdate -> P (HsExpr RdrName) mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c - = return (RecordCon (L l c) fs) + = return (RecordCon (L l c) noPostTcExpr fs) mkRecConstrOrUpdate exp loc fs@(_:_) - = return (RecordUpd exp 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 + + ----------------------------------------------------------------------------- -- utilities for foreign declarations @@ -771,8 +802,8 @@ mkExport :: CallConv mkExport (CCall cconv) (L loc entity, v, ty) = return $ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False) where - entity' | nullFastString entity = mkExtName (unLoc v) - | otherwise = entity + 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" @@ -782,10 +813,9 @@ mkExport DNCall (L loc entity, v, ty) = -- of the Haskell name is then performed, so if you foreign export (++), -- it's external name will be "++". Too bad; it's important because we don't -- want z-encoding (e.g. names with z's in them shouldn't be doubled) --- (This is why we use occNameUserString.) -- mkExtName :: RdrName -> CLabelString -mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm)) +mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) \end{code}