X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=236d53859a1709d952ddaf2d4fda1a29ce7dce96;hb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;hp=3761f74f44550e64bd66e01781e17761310b3e6c;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 3761f74..236d538 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -1,23 +1,16 @@ % -% (c) The AQUA Project, Glasgow University, 1996-1998 -% -\section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader} +% (c) The University of Glasgow, 1996-2003 -(Well, really, for specialisations involving @RdrName@s, even if -they are used somewhat later on in the compiler...) +Functions over HsSyn specialised to RdrName. \begin{code} module RdrHsSyn ( - RdrBinding(..), - - main_RDR_Unqual, - extractHsTyRdrTyVars, extractHsRhoRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, mkHsNegApp, mkHsIntegral, mkHsFractional, - mkHsDo, mkHsSplice, mkSigDecls, + mkHsDo, mkHsSplice, mkTyData, mkPrefixCon, mkRecCon, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkBootIface, @@ -57,25 +50,25 @@ module RdrHsSyn ( import HsSyn -- Lots of it import IfaceType -import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) -import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) ) +import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache, + IfacePackage(..) ) +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 ) import Lexer ( P, failSpanMsgP ) +import Kind ( liftedTypeKind ) import HscTypes ( GenAvailInfo(..) ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), - DNCallSpec(..), DNKind(..)) + DNCallSpec(..), DNKind(..), CLabelString ) import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc, occNameUserString, isValOcc ) -import BasicTypes ( initialVersion ) -import TyCon ( DataConDetails(..) ) -import Module ( ModuleName ) +import BasicTypes ( initialVersion, StrictnessMark(..) ) +import Module ( Module ) import SrcLoc -import CStrings ( CLabelString ) -import CmdLineOpts ( opt_InPackage ) +import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable import FastString @@ -84,19 +77,6 @@ import Panic import List ( isSuffixOf, nubBy ) \end{code} - -%************************************************************************ -%* * -\subsection{Type synonyms} -%* * -%************************************************************************ - -\begin{code} -main_RDR_Unqual :: RdrName -main_RDR_Unqual = mkUnqual varName FSLIT("main") - -- We definitely don't want an Orig RdrName, because - -- main might, in principle, be imported into module Main -\end{code} %************************************************************************ %* * @@ -104,7 +84,7 @@ main_RDR_Unqual = mkUnqual varName FSLIT("main") %* * %************************************************************************ -@extractHsTyRdrNames@ finds the free variables of a HsType +extractHsTyRdrNames finds the free variables of a HsType It's used when making the for-alls explicit. \begin{code} @@ -127,15 +107,17 @@ extract_lty (L loc (HsTyVar 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 (unLoc p) 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) @@ -150,8 +132,8 @@ extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName] extractGenericPatTyVars binds = nubBy eqLocated (foldrBag get [] binds) where - get (L _ (FunBind _ _ 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 @@ -179,13 +161,13 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = 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} @@ -206,9 +188,11 @@ mkHsNegApp (L loc e) = f e %* * %************************************************************************ -mkBootIface, and its boring helper functions, have two purposes: +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 @@ -216,14 +200,18 @@ b) Convert unqualifed names from the "current module" to qualified Orig becomes This.foo :: GHC.Base.Int -> GHC.Base.Int -It assumes that everything is well kinded, of course. +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 +mkBootIface :: Module -> [HsDecl RdrName] -> ModIface -- Make the ModIface for a hi-boot file -- The decls are of very limited form +-- The package will be filled in later (see LoadIface.readIface) mkBootIface mod decls - = (emptyModIface opt_InPackage mod) { + = (emptyModIface ThisPackage{-fill in later-} mod) { mi_boot = True, mi_exports = [(mod, map mk_export decls')], mi_decls = decls_w_vers, @@ -252,6 +240,14 @@ hsIfaceDecl (SigD (Sig name ty)) 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), @@ -259,24 +255,69 @@ hsIfaceDecl (TyClD decl@(TySynonym {})) ifVrcs = [] } hsIfaceDecl (TyClD decl@(TyData {})) - = IfaceData { ifND = tcdND decl, - ifName = rdrNameOcc (tcdName decl), - ifTyVars = hsIfaceTvs (tcdTyVars decl), - ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), - ifCons = Unknown, ifRec = NonRecursive, + = IfaceData { ifName = rdrNameOcc (tcdName decl), + ifTyVars = tvs, + ifCons = hsIfaceCons tvs decl, + ifRec = Recursive, -- Hi-boot decls are always loop-breakers 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 - -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 decl = pprPanic "hsIfaceDecl" (ppr decl) + 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 @@ -304,9 +345,11 @@ 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 (HsNumTy n) = panic "hsIfaceType:HsNum" -hsIfaceType (HsPredTy p) = IfacePredTy (hsIfaceLPred p) +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 @@ -332,11 +375,12 @@ hs_tc_app (HsTyVar 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, IfaceLiftedTypeKind) -hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k) +hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind) +hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k) ----------- hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])] @@ -344,25 +388,6 @@ hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys) | (xs,ys) <- fds ] \end{code} - -%************************************************************************ -%* * -\subsection[rdrBinding]{Bindings straight out of the parser} -%* * -%************************************************************************ - -\begin{code} -data RdrBinding - = -- Value bindings havn't been united with their - -- signatures yet - RdrBindings [RdrBinding] -- Convenience for parsing - - | RdrValBinding (LHsBind RdrName) - - -- The remainder all fit into the main HsDecl form - | RdrHsDecl (LHsDecl RdrName) -\end{code} - %************************************************************************ %* * \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.} @@ -375,44 +400,39 @@ analyser. \begin{code} -cvTopDecls :: [RdrBinding] -> [LHsDecl RdrName] --- Incoming bindings are in reverse order; result is in ordinary order --- (a) flatten RdrBindings --- (b) Group together bindings for a single function -cvTopDecls decls - = go [] decls +-- | Groups together bindings for a single function +cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName] +cvTopDecls decls = go (fromOL decls) where - go :: [LHsDecl RdrName] -> [RdrBinding] -> [LHsDecl RdrName] - go acc [] = acc - go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2 - go acc (RdrHsDecl d : ds) = go (d : acc) ds - go acc (RdrValBinding b : ds) = go (L l (ValD b') : acc) ds' - where - (L l b', ds') = getMonoBind b ds - -cvBindGroup :: [RdrBinding] -> HsBindGroup RdrName + go :: [LHsDecl RdrName] -> [LHsDecl RdrName] + go [] = [] + go (L l (ValD b) : ds) = L l' (ValD b') : go ds' + where (L l' b', ds') = getMonoBind (L l b) ds + go (d : ds) = d : go ds + +cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName cvBindGroup binding = case (cvBindsAndSigs binding) of { (mbs, sigs) -> HsBindGroup mbs sigs Recursive -- just one big group for now } -cvBindsAndSigs :: [RdrBinding] -> (Bag (LHsBind RdrName), [LSig RdrName]) --- Input bindings are in *reverse* order, --- and contain just value bindings and signatures -cvBindsAndSigs fb - = go (emptyBag, []) fb +cvBindsAndSigs :: OrdList (LHsDecl RdrName) + -> (Bag (LHsBind RdrName), [LSig RdrName]) +-- Input decls contain just value bindings and signatures +cvBindsAndSigs fb = go (fromOL fb) where - go acc [] = acc - go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2 - go (bs, ss) (RdrHsDecl (L l (SigD s)) : ds) = go (bs, L l s : ss) ds - go (bs, ss) (RdrValBinding b : ds) = go (b' `consBag` bs, ss) ds' - where - (b',ds') = getMonoBind b ds + go [] = (emptyBag, []) + go (L l (SigD s) : ds) = (bs, L l s : ss) + where (bs,ss) = go ds + go (L l (ValD b) : ds) = (b' `consBag` bs, ss) + where (b',ds') = getMonoBind (L l b) ds + (bs,ss) = go ds' ----------------------------------------------------------------------------- -- Group function bindings into equation groups -getMonoBind :: LHsBind RdrName -> [RdrBinding] -> (LHsBind RdrName, [RdrBinding]) +getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] + -> (LHsBind RdrName, [LHsDecl RdrName]) -- Suppose (b',ds') = getMonoBind b ds -- ds is a *reversed* list of parsed bindings -- b is a MonoBinds that has just been read off the front @@ -423,16 +443,17 @@ getMonoBind :: LHsBind RdrName -> [RdrBinding] -> (LHsBind RdrName, [RdrBinding] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds +-- gaw 2004 +getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds | has_args mtchs = go mtchs loc binds where - go mtchs1 loc1 (RdrValBinding (L loc2 (FunBind f2 inf2 mtchs2)) : binds) - | f == unLoc f2 = go (mtchs2 ++ mtchs1) loc binds - -- Remember binds is reversed, so glue mtchs2 on the front - -- and use loc2 as the final location + 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 mtchs1), binds) + 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 getMonoBind bind binds = (bind, binds) @@ -465,7 +486,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 @@ -529,7 +550,7 @@ mkPrefixCon :: LHsType RdrName -> [LBangType RdrName] mkPrefixCon ty tys = split ty tys where - split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts) + 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, PrefixCon ts) split (L l _) _ = parseError l "parse error in data/newtype declaration" @@ -628,7 +649,7 @@ checkPred :: LHsType RdrName -> P (LHsPred RdrName) -- Watch out.. in ...deriving( Show )... we use checkPred on -- the list of partially applied predicates in the deriving, -- so there can be zero args. -checkPred (L spn (HsPredTy (L _ (HsIParam n ty))) ) +checkPred (L spn (HsPredTy (HsIParam n ty))) = return (L spn (HsIParam n ty)) checkPred (L spn ty) = check spn ty [] @@ -644,8 +665,8 @@ checkPred (L spn ty) checkDictTy :: LHsType RdrName -> P (LHsType RdrName) checkDictTy (L spn ty) = check ty [] where - check (HsTyVar t) args@(_:_) | not (isRdrTyVar t) - = return (L spn (HsPredTy (L spn (HsClassP t args)))) + check (HsTyVar t) args | not (isRdrTyVar t) + = return (L spn (HsPredTy (HsClassP t args))) check (HsAppTy l r) args = check (unLoc l) (r:args) check (HsParTy t) args = check (unLoc t) args check _ _ = parseError spn "Malformed context in instance header" @@ -757,8 +778,6 @@ checkAPat loc e = case e of HsType ty -> return (TypePat ty) _ -> patFail loc -checkAPat loc _ = patFail loc - checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName) checkPatField (n,e) = do p <- checkLPat e @@ -773,20 +792,22 @@ patFail loc = parseError loc "Parse error in pattern" checkValDef :: LHsExpr RdrName -> Maybe (LHsType RdrName) - -> GRHSs RdrName + -> Located (GRHSs RdrName) -> P (HsBind RdrName) -checkValDef lhs opt_sig grhss +checkValDef lhs opt_sig (L rhs_span grhss) | Just (f,inf,es) <- isFunLhs lhs [] = if isQual (unLoc f) then parseError (getLoc f) ("Qualified name in function definition: " ++ showRdrName (unLoc f)) else do ps <- checkPatterns es - return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)]) - -- TODO: span is wrong + let match_span = combineSrcSpans (getLoc lhs) rhs_span + return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)])) + -- 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) + return (PatBind lhs grhss placeHolderType) checkValSig :: LHsExpr RdrName @@ -796,10 +817,6 @@ checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty) checkValSig (L l other) ty = parseError l "Type signature given for an expression" -mkSigDecls :: [LSig RdrName] -> RdrBinding -mkSigDecls sigs = RdrBindings [RdrHsDecl (L l (SigD sig)) | L l sig <- sigs] - - -- A variable binding is parsed as a FunBind. isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]