X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=5a258a19e979366d4700448bd152110f3eded7d0;hb=9e4a57507258b242de787bd4263887ba90760139;hp=ae1000728a044694fb592903aeab21313fb0dc59;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index ae10007..5a258a1 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -13,7 +13,6 @@ module RdrHsSyn ( mkHsDo, mkHsSplice, mkTyData, mkPrefixCon, mkRecCon, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp - mkBootIface, cvBindGroup, cvBindsAndSigs, @@ -35,7 +34,8 @@ module RdrHsSyn ( , checkPrecP -- Int -> P Int , checkContext -- HsType -> P HsContext , checkPred -- HsType -> P HsPred - , checkTyClHdr -- HsType -> (name,[tyvar]) + , checkTyClHdr + , checkSynHdr , checkInstType -- HsType -> P HsType , checkPattern -- HsExp -> P HsPat , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat] @@ -49,25 +49,17 @@ module RdrHsSyn ( #include "HsVersions.h" import HsSyn -- Lots of it -import IfaceType -import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) -import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) ) import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, - setRdrNameSpace, rdrNameModule ) -import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion ) + setRdrNameSpace ) +import BasicTypes ( RecFlag(..), maxPrecedence ) import Lexer ( P, failSpanMsgP ) -import Kind ( liftedTypeKind ) -import HscTypes ( GenAvailInfo(..) ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..), CLabelString ) -import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc, - occNameUserString, isValOcc ) -import BasicTypes ( initialVersion, StrictnessMark(..) ) -import Module ( ModuleName ) +import OccName ( srcDataName, varName, isDataOcc, isTcOcc, + occNameUserString ) import SrcLoc -import CmdLineOpts ( opt_InPackage ) import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable @@ -97,34 +89,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 @@ -164,10 +157,10 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds tcdMeths = mbinds } -mkTyData new_or_data (context, tname, tyvars) data_cons maybe +mkTyData new_or_data (L _ (context, tname, tyvars)) ksig data_cons maybe_deriv = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname, tcdTyVars = tyvars, tcdCons = data_cons, - tcdDerivs = maybe } + tcdKindSig = ksig, tcdDerivs = maybe_deriv } \end{code} \begin{code} @@ -184,211 +177,6 @@ mkHsNegApp (L loc e) = f e %************************************************************************ %* * - Hi-boot files -%* * -%************************************************************************ - -mkBootIface, and its deeply boring helper functions, have two purposes: - -a) HsSyn to IfaceSyn. The parser parses the former, but we're reading - an hi-boot file, and interfaces consist of the latter - -b) Convert unqualifed names from the "current module" to qualified Orig - names. E.g. - module This where - foo :: GHC.Base.Int -> GHC.Base.Int - becomes - This.foo :: GHC.Base.Int -> GHC.Base.Int - -It assumes that everything is well kinded, of course. Failure causes a -fatal error using pgmError, rather than a monadic error. You're supposed -to get hi-boot files right! - - -\begin{code} -mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface --- Make the ModIface for a hi-boot file --- The decls are of very limited form -mkBootIface mod decls - = (emptyModIface opt_InPackage mod) { - mi_boot = True, - mi_exports = [(mod, map mk_export decls')], - mi_decls = decls_w_vers, - mi_ver_fn = mkIfaceVerCache decls_w_vers } - where - decls' = map hsIfaceDecl decls - decls_w_vers = repeat initialVersion `zip` decls' - - -- hi-boot declarations don't (currently) - -- expose constructors or class methods - mk_export decl | isValOcc occ = Avail occ - | otherwise = AvailTC occ [occ] - where - occ = ifName decl - - -hsIfaceDecl :: HsDecl RdrName -> IfaceDecl - -- Change to Iface syntax, and replace unqualified names with - -- qualified Orig names from this module. Reason: normal - -- iface files have everything fully qualified, so it's convenient - -- for hi-boot files to look the same - -- - -- NB: no constructors or class ops to worry about -hsIfaceDecl (SigD (Sig name ty)) - = IfaceId { ifName = rdrNameOcc (unLoc name), - ifType = hsIfaceLType ty, - ifIdInfo = NoInfo } - -hsIfaceDecl (TyClD decl@(ClassDecl {})) - = IfaceClass { ifName = rdrNameOcc (tcdName decl), - ifTyVars = hsIfaceTvs (tcdTyVars decl), - ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), - ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)), - ifSigs = [], -- Is this right?? - ifRec = NonRecursive, ifVrcs = [] } - -hsIfaceDecl (TyClD decl@(TySynonym {})) - = IfaceSyn { ifName = rdrNameOcc (tcdName decl), - ifTyVars = hsIfaceTvs (tcdTyVars decl), - ifSynRhs = hsIfaceLType (tcdSynRhs decl), - ifVrcs = [] } - -hsIfaceDecl (TyClD decl@(TyData {})) - = IfaceData { ifName = rdrNameOcc (tcdName decl), - ifTyVars = tvs, - ifCons = hsIfaceCons tvs decl, - ifRec = NonRecursive, - ifVrcs = [], ifGeneric = False } - -- I'm not sure that [] is right for ifVrcs, but - -- since we don't use them I'm not going to fiddle - where - tvs = hsIfaceTvs (tcdTyVars decl) - -hsIfaceDecl decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl) - -hsIfaceCons :: [IfaceTvBndr] -> TyClDecl RdrName -> IfaceConDecls -hsIfaceCons tvs decl@(TyData {tcdCtxt = L _ stupid_ctxt}) - | not (null stupid_ctxt) -- Keep it simple: no data type contexts - -- Else we'll have to do "thinning"; sigh - = pprPgmError "Can't do data type contexts in hi-boot file:" (ppr decl) - -hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = []}) - = -- data T a, meaning "constructors unspecified", - IfAbstractTyCon -- not "no constructors" - -hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = cons}) - = IfDataTyCon Nothing (map (hsIfaceCon tvs . unLoc) cons) - -hsIfaceCons tvs (TyData {tcdND = NewType, tcdCons = [con]}) - = IfNewTyCon (hsIfaceCon tvs (unLoc con)) - -hsIfaceCons tvs decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl) - - -hsIfaceCon :: [IfaceTvBndr] -> ConDecl RdrName -> IfaceConDecl -hsIfaceCon tvs (ConDecl lname ex_tvs ex_ctxt details) - | null ex_tvs && null (unLoc ex_ctxt) - = IfVanillaCon { ifConOcc = get_occ lname, - ifConInfix = is_infix, - ifConArgTys = map hsIfaceLType args, - ifConStricts = map (hsStrictMark . getBangStrictness) args, - ifConFields = flds } - | null flds - = IfGadtCon { ifConOcc = get_occ lname, - ifConTyVars = tvs ++ hsIfaceTvs ex_tvs, - ifConCtxt = hsIfaceCtxt (unLoc ex_ctxt), - ifConArgTys = map hsIfaceLType args, - ifConResTys = map (IfaceTyVar . fst) tvs, - ifConStricts = map (hsStrictMark . getBangStrictness) args } - | otherwise = pprPgmError "Fields illegal in existential" (ppr (unLoc lname)) - where - (is_infix, args, flds) = case details of - PrefixCon args -> (False, args, []) - InfixCon a1 a2 -> (True, [a1,a2], []) - RecCon fs -> (False, map snd fs, map (get_occ . fst) fs) - get_occ lname = rdrNameOcc (unLoc lname) - -hsIfaceCon _tvs (GadtDecl lname con_ty) -- Not yet - = pprPgmError "Can't use GADTs in hi-boot files (yet)" (ppr (unLoc lname)) - -hsStrictMark :: HsBang -> StrictnessMark --- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request --- but in an hi-boot file it's interpreted as the Truth! -hsStrictMark HsNoBang = NotMarkedStrict -hsStrictMark HsStrict = MarkedStrict -hsStrictMark HsUnbox = MarkedUnboxed - -hsIfaceName rdr_name -- Qualify unqualifed occurrences - -- with the module name - | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name) - | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name) - -hsIfaceLType :: LHsType RdrName -> IfaceType -hsIfaceLType = hsIfaceType . unLoc - -hsIfaceType :: HsType RdrName -> IfaceType -hsIfaceType (HsForAllTy exp tvs cxt ty) - = foldr (IfaceForAllTy . hsIfaceTv) rho tvs' - where - rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt) - tau = hsIfaceLType ty - tvs' = case exp of - Explicit -> map unLoc tvs - Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty) - -hsIfaceType ty@(HsTyVar _) = hs_tc_app ty [] -hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty [] -hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2) -hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t] -hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t] -hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts) -hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2]) -hsIfaceType (HsParTy t) = hsIfaceLType t -hsIfaceType (HsBangTy _ t) = hsIfaceLType t -hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p) -hsIfaceType (HsKindSig t _) = hsIfaceLType t -hsIfaceType ty = pprPanic "hsIfaceType" (ppr ty) - -- HsNumTy, HsSpliceTy - ------------ -hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys - ------------ -hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType] -hsIfaceCtxt ctxt = map hsIfaceLPred ctxt - ------------ -hsIfaceLPred :: LHsPred RdrName -> IfacePredType -hsIfaceLPred = hsIfacePred . unLoc - -hsIfacePred :: HsPred RdrName -> IfacePredType -hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts) -hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t) - ------------ -hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType -hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args) -hs_tc_app (HsTyVar n) args - | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args - | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args -hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args - ------------ -hsIfaceTvs :: [LHsTyVarBndr RdrName] -> [IfaceTvBndr] -hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs - ------------ -hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind) -hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k) - ------------ -hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])] -hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys) - | (xs,ys) <- fds ] -\end{code} - -%************************************************************************ -%* * \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.} %* * %************************************************************************ @@ -485,7 +273,7 @@ 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 [] = (gp, Nothing) addl gp (L l d : ds) = add gp l d ds @@ -594,6 +382,10 @@ checkTyVars tvs chk (L l other) = parseError l "Type found where type variable expected" +checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName]) +checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty + ; return (tc, tvs) } + checkTyClHdr :: LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) -- The header of a type or class decl should look like @@ -655,11 +447,12 @@ checkPred (L spn ty) where checkl (L l ty) args = check l ty args - 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 (HsParTy t) args = checkl t args - check loc _ _ = parseError loc "malformed class assertion" + 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 []