X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=b51c2d5a9b592770205de16a82a6df28aace1ae8;hb=1b9841866c2b49484a3af10ab2d8f5bb6d68ab84;hp=3761f74f44550e64bd66e01781e17761310b3e6c;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 3761f74..b51c2d5 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, @@ -58,24 +51,24 @@ module RdrHsSyn ( import HsSyn -- Lots of it import IfaceType import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) -import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) ) +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 BasicTypes ( initialVersion, StrictnessMark(..) ) import Module ( ModuleName ) 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} @@ -132,10 +112,11 @@ 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) @@ -179,7 +160,7 @@ 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 @@ -259,11 +240,11 @@ hsIfaceDecl (TyClD decl@(TySynonym {})) ifVrcs = [] } hsIfaceDecl (TyClD decl@(TyData {})) - = IfaceData { ifND = tcdND decl, - ifName = rdrNameOcc (tcdName decl), + = IfaceData { ifName = rdrNameOcc (tcdName decl), ifTyVars = hsIfaceTvs (tcdTyVars decl), ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), - ifCons = Unknown, ifRec = NonRecursive, + ifCons = hsIfaceCons (tcdND decl) (tcdCons 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 @@ -278,6 +259,39 @@ hsIfaceDecl (TyClD decl@(ClassDecl {})) hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl) +hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls +hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified", + = IfAbstractTyCon -- not "no constructors" + +hsIfaceCons DataType cons -- data type + = IfDataTyCon (map (hsIfaceCon . unLoc) cons) + +hsIfaceCons NewType [con] -- newtype + = IfNewTyCon (hsIfaceCon (unLoc con)) + + +hsIfaceCon :: ConDecl RdrName -> IfaceConDecl +hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details) + = IfaceConDecl (get_occ lname) is_infix + (hsIfaceTvs ex_tvs) + (hsIfaceCtxt (unLoc ex_ctxt)) + (map (hsIfaceLType . getBangType . unLoc) args) + (map (hsStrictMark . getBangStrictness . unLoc) args) + flds + 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) + +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) @@ -304,9 +318,10 @@ 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 (HsPredTy p) = IfacePredTy (hsIfacePred p) hsIfaceType (HsKindSig t _) = hsIfaceLType t +hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum" +hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy" ----------- hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys @@ -335,8 +350,8 @@ hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args 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 +359,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 +371,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 @@ -427,12 +418,12 @@ getMonoBind (L loc (FunBind lf@(L _ f) inf 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 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 (reverse mtchs1)), binds) + -- reverse the final matches, to get it back in the right order getMonoBind bind binds = (bind, binds) @@ -628,7 +619,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 +635,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 +748,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 +762,23 @@ 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 [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) + checkValSig :: LHsExpr RdrName @@ -796,10 +788,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]