X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=101ada1595f5837606d5ef585e1a74e397be0ef9;hb=16e4ce4c0c02650082f2e11982017c903c549ad5;hp=57eb5a8e08223306d005e2ee9851ee814cf030a9;hpb=1b471823339bc0bdbf3d1b6a64028f90c4ff1f77;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 57eb5a8..101ada1 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -16,9 +16,12 @@ module RdrHsSyn ( RdrNameContext, RdrNameDefaultDecl, RdrNameForeignDecl, + RdrNameCoreDecl, RdrNameGRHS, RdrNameGRHSs, RdrNameHsBinds, + RdrNameHsCmd, + RdrNameHsCmdTop, RdrNameHsDecl, RdrNameHsExpr, RdrNameHsModule, @@ -41,38 +44,74 @@ module RdrHsSyn ( RdrBinding(..), RdrMatch(..), - SigConverter, - extractHsTyRdrNames, - extractHsTyRdrTyVars, extractHsTysRdrTyVars, - extractPatsTyVars, - extractRuleBndrsTyVars, + main_RDR_Unqual, + + extractHsTyRdrNames, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars, - mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl, - mkHsNegApp, + mkHsOpApp, mkClassDecl, + mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, + mkHsDo, mkHsSplice, mkSigDecls, + mkTyData, mkPrefixCon, mkRecCon, + mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp + mkIfaceExports, -- :: [RdrNameTyClDecl] -> [RdrExportItem] cvBinds, cvMonoBindsAndSigs, cvTopDecls, - cvValSig, cvClassOpSig, cvInstDeclSig, - mkTyData + findSplice, addImpDecls, emptyGroup, mkGroup, + + -- Stuff to do with Foreign declarations + , CallConv(..) + , mkImport -- CallConv -> Safety + -- -> (FastString, RdrName, RdrNameHsType) + -- -> SrcLoc + -- -> P RdrNameHsDecl + , mkExport -- CallConv + -- -> (FastString, RdrName, RdrNameHsType) + -- -> SrcLoc + -- -> P RdrNameHsDecl + , mkExtName -- RdrName -> CLabelString + + -- Bunch of functions in the parser monad for + -- checking and constructing values + , checkPrecP -- Int -> P Int + , checkContext -- HsType -> P HsContext + , checkPred -- HsType -> P HsPred + , checkTyVars -- [HsTyVar] -> P [HsType] + , checkTyClHdr -- HsType -> (name,[tyvar]) + , 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 HsPat ( collectSigTysFromPats ) -import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, - mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1, - mkGenOcc2, - ) -import PrelNames ( negate_RDR ) -import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, - ) -import List ( nub ) -import BasicTypes ( RecFlag(..) ) +import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc, + isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, + setRdrNameSpace ) +import BasicTypes ( RecFlag(..), FixitySig(..), maxPrecedence ) import Class ( DefMeth (..) ) +import Lex ( P, mapP, setSrcLocP, thenP, returnP, getSrcLocP, failMsgP ) +import HscTypes ( RdrAvailInfo, GenAvailInfo(..) ) +import TysWiredIn ( unitTyCon ) +import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), + DNCallSpec(..), DNKind(..)) +import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString, + mkDefaultMethodOcc, mkVarOcc ) +import SrcLoc +import CStrings ( CLabelString ) +import List ( isSuffixOf, nub ) +import Outputable +import FastString +import Panic \end{code} @@ -83,40 +122,49 @@ import Class ( DefMeth (..) ) %************************************************************************ \begin{code} -type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat +type RdrNameArithSeqInfo = ArithSeqInfo RdrName type RdrNameBangType = BangType RdrName type RdrNameClassOpSig = Sig RdrName type RdrNameConDecl = ConDecl RdrName -type RdrNameConDetails = ConDetails RdrName +type RdrNameConDetails = HsConDetails RdrName RdrNameBangType type RdrNameContext = HsContext RdrName -type RdrNameHsDecl = HsDecl RdrName RdrNamePat +type RdrNameHsDecl = HsDecl RdrName type RdrNameDefaultDecl = DefaultDecl RdrName type RdrNameForeignDecl = ForeignDecl RdrName -type RdrNameGRHS = GRHS RdrName RdrNamePat -type RdrNameGRHSs = GRHSs RdrName RdrNamePat -type RdrNameHsBinds = HsBinds RdrName RdrNamePat -type RdrNameHsExpr = HsExpr RdrName RdrNamePat -type RdrNameHsModule = HsModule RdrName RdrNamePat +type RdrNameCoreDecl = CoreDecl RdrName +type RdrNameGRHS = GRHS RdrName +type RdrNameGRHSs = GRHSs RdrName +type RdrNameHsBinds = HsBinds RdrName +type RdrNameHsExpr = HsExpr RdrName +type RdrNameHsCmd = HsCmd RdrName +type RdrNameHsCmdTop = HsCmdTop RdrName +type RdrNameHsModule = HsModule RdrName type RdrNameIE = IE RdrName type RdrNameImportDecl = ImportDecl RdrName -type RdrNameInstDecl = InstDecl RdrName RdrNamePat -type RdrNameMatch = Match RdrName RdrNamePat -type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat +type RdrNameInstDecl = InstDecl RdrName +type RdrNameMatch = Match RdrName +type RdrNameMonoBinds = MonoBinds RdrName type RdrNamePat = InPat RdrName type RdrNameHsType = HsType RdrName type RdrNameHsTyVar = HsTyVarBndr RdrName type RdrNameSig = Sig RdrName -type RdrNameStmt = Stmt RdrName RdrNamePat -type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat +type RdrNameStmt = Stmt RdrName +type RdrNameTyClDecl = TyClDecl RdrName type RdrNameRuleBndr = RuleBndr RdrName -type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat +type RdrNameRuleDecl = RuleDecl RdrName type RdrNameDeprecation = DeprecDecl RdrName type RdrNameFixitySig = FixitySig RdrName -type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat +type RdrNameHsRecordBinds = HsRecordBinds RdrName \end{code} +\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} %************************************************************************ %* * @@ -128,20 +176,11 @@ type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat It's used when making the for-alls explicit. \begin{code} -extractHsTyRdrNames :: HsType RdrName -> [RdrName] +extractHsTyRdrNames :: RdrNameHsType -> [RdrName] extractHsTyRdrNames ty = nub (extract_ty ty []) -extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName] -extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty) - -extractHsTysRdrTyVars :: [RdrNameHsType] -> [RdrName] -extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys)) - -extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName] -extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs)) - where - go (RuleBndr _) acc = acc - go (RuleBndrSig _ ty) acc = extract_ty ty acc +extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName] +extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty [])) extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName] extractHsCtxtRdrNames ty = nub (extract_ctxt ty []) @@ -150,22 +189,24 @@ extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty) extract_ctxt ctxt acc = foldr extract_pred acc ctxt -extract_pred (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys -extract_pred (HsPIParam n ty) acc = extract_ty ty acc +extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys +extract_pred (HsIParam n ty) acc = extract_ty ty acc extract_tys tys = foldr extract_ty [] tys extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsListTy ty) acc = extract_ty ty acc +extract_ty (HsPArrTy ty) acc = extract_ty ty acc extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsPredTy p) acc = extract_pred p acc extract_ty (HsTyVar tv) acc = tv : acc -extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc) +extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc) +extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsParTy ty) acc = extract_ty ty acc -- Generics -extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsNumTy num) acc = acc --- Generics +extract_ty (HsKindSig ty k) acc = extract_ty ty acc extract_ty (HsForAllTy (Just tvs) ctxt ty) acc = acc ++ (filter (`notElem` locals) $ @@ -173,13 +214,6 @@ extract_ty (HsForAllTy (Just tvs) ctxt ty) where locals = hsTyVarNames tvs - -extractPatsTyVars :: [RdrNamePat] -> [RdrName] -extractPatsTyVars = filter isRdrTyVar . - nub . - extract_tys . - collectSigTysFromPats - extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName] -- Get the type variables out of the type patterns in a bunch of -- possibly-generic bindings in a class declaration @@ -190,8 +224,8 @@ extractGenericPatTyVars binds get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms get other acc = acc - get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc - get_m other acc = acc + get_m (Match (TypePat ty : _) _ _) acc = extract_ty ty acc + get_m other acc = acc \end{code} @@ -212,45 +246,25 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. *** See "THE NAMING STORY" in HsDecls **** \begin{code} -mkClassDecl cxt cname tyvars fds sigs mbinds loc +mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars, - tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, - tcdSysNames = new_names, tcdLoc = loc } + tcdFDs = fds, + tcdSigs = map cvClassOpSig sigs, -- Convert to class-op sigs + tcdMeths = mbinds, + tcdLoc = loc } + +mkTyData new_or_data (context, tname, tyvars) data_cons maybe src + = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname, + tcdTyVars = tyvars, tcdCons = data_cons, + tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing } + +cvClassOpSig :: RdrNameSig -> RdrNameSig +cvClassOpSig (Sig var poly_ty src_loc) + = ClassOpSig var (DefMeth dm_rn) poly_ty src_loc where - cls_occ = rdrNameOcc cname - data_occ = mkClassDataConOcc cls_occ - dname = mkRdrUnqual data_occ - dwname = mkRdrUnqual (mkWorkerOcc data_occ) - tname = mkRdrUnqual (mkClassTyConOcc cls_occ) - sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ) - | n <- [1..length cxt]] - -- We number off the superclass selectors, 1, 2, 3 etc so that we - -- can construct names for the selectors. Thus - -- class (C a, C b) => D a b where ... - -- gives superclass selectors - -- D_sc1, D_sc2 - -- (We used to call them D_C, but now we can have two different - -- superclasses both called C!) - new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names) - --- mkTyData :: ?? -mkTyData new_or_data context tname list_var list_con i maybe src - = let t_occ = rdrNameOcc tname - name1 = mkRdrUnqual (mkGenOcc1 t_occ) - name2 = mkRdrUnqual (mkGenOcc2 t_occ) - in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname, - tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i, - tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] } - -mkClassOpSigDM op ty loc - = ClassOpSig op (DefMeth dm_rn) ty loc - where - dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op)) - -mkConDecl cname ex_vars cxt details loc - = ConDecl cname wkr_name ex_vars cxt details loc - where - wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname)) + dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc var)) +cvClassOpSig sig + = sig \end{code} \begin{code} @@ -258,21 +272,11 @@ mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr -- 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! --- --- We also do the same service for boxed literals, because this function --- is also used for patterns (which, remember, are parsed as expressions) --- and pattern don't have negation in them. --- --- Finally, it's important to represent minBound as minBound, and not --- as (negate (-minBound)), becuase the latter is out of range. mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i)) mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i)) mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) - -mkHsNegApp (HsOverLit (HsIntegral i n)) = HsOverLit (HsIntegral (-i) n) -mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n) -mkHsNegApp expr = NegApp expr negate_RDR +mkHsNegApp expr = NegApp expr placeHolderName \end{code} A useful function for building @OpApps@. The operator is always a @@ -282,6 +286,23 @@ variable, and we don't know the fixity yet. mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2 \end{code} +These are the bits of syntax that contain rebindable names +See RnEnv.lookupSyntaxName + +\begin{code} +mkHsIntegral i = HsIntegral i placeHolderName +mkHsFractional f = HsFractional f placeHolderName +mkNPlusKPat n k = NPlusKPatIn n k placeHolderName +mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc +\end{code} + +\begin{code} +mkHsSplice e loc = HsSplice unqualSplice e loc + +unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice")) + -- A name (uniquified later) to + -- identify the splice +\end{code} %************************************************************************ %* * @@ -291,23 +312,14 @@ mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2 \begin{code} data RdrBinding - = -- On input we use the Empty/And form rather than a list - RdrNullBind - | RdrAndBindings RdrBinding RdrBinding - - -- Value bindings havn't been united with their + = -- Value bindings havn't been united with their -- signatures yet - | RdrValBinding RdrNameMonoBinds + RdrBindings [RdrBinding] -- Convenience for parsing - -- Signatures are mysterious; we can't - -- tell if its a Sig or a ClassOpSig, - -- so we just save the pieces: - | RdrSig RdrNameSig + | RdrValBinding RdrNameMonoBinds -- The remainder all fit into the main HsDecl form | RdrHsDecl RdrNameHsDecl - -type SigConverter = RdrNameSig -> RdrNameSig \end{code} \begin{code} @@ -320,27 +332,6 @@ data RdrMatch %************************************************************************ %* * -\subsection[cvDecls]{Convert various top-level declarations} -%* * -%************************************************************************ - -We make a point not to throw any user-pragma ``sigs'' at -these conversion functions: - -\begin{code} -cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter - -cvValSig sig = sig - -cvInstDeclSig sig = sig - -cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc -cvClassOpSig sig = sig -\end{code} - - -%************************************************************************ -%* * \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.} %* * %************************************************************************ @@ -349,38 +340,127 @@ Function definitions are restructured here. Each is assumed to be recursive initially, and non recursive definitions are discovered by the dependency analyser. -\begin{code} -cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds - -- The mysterious SigConverter converts Sigs to ClassOpSigs - -- in class declarations. Mostly it's just an identity function -cvBinds sig_cvtr binding - = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) -> +\begin{code} +cvTopDecls :: [RdrBinding] -> [RdrNameHsDecl] +-- 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 + where + go :: [RdrNameHsDecl] -> [RdrBinding] -> [RdrNameHsDecl] + 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 (ValD b' : acc) ds' + where + (b', ds') = getMonoBind b ds + +cvBinds :: [RdrBinding] -> RdrNameHsBinds +cvBinds binding + = case (cvMonoBindsAndSigs binding) of { (mbs, sigs) -> MonoBind mbs sigs Recursive } -\end{code} -\begin{code} -cvMonoBindsAndSigs :: SigConverter - -> RdrBinding - -> (RdrNameMonoBinds, [RdrNameSig]) +cvMonoBindsAndSigs :: [RdrBinding] -> (RdrNameMonoBinds, [RdrNameSig]) +-- Input bindings are in *reverse* order, +-- and contain just value bindings and signatuers -cvMonoBindsAndSigs sig_cvtr fb - = mangle_bind (EmptyMonoBinds, []) fb +cvMonoBindsAndSigs fb + = go (EmptyMonoBinds, []) fb where - mangle_bind acc RdrNullBind - = acc - - mangle_bind acc (RdrAndBindings fb1 fb2) - = mangle_bind (mangle_bind acc fb1) fb2 - - mangle_bind (b_acc, s_acc) (RdrSig sig) - = (b_acc, sig_cvtr sig : s_acc) - - mangle_bind (b_acc, s_acc) (RdrValBinding binding) - = (b_acc `AndMonoBinds` binding, s_acc) + go acc [] = acc + go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2 + go (bs, ss) (RdrHsDecl (SigD s) : ds) = go (bs, s : ss) ds + go (bs, ss) (RdrValBinding b : ds) = go (b' `AndMonoBinds` bs, ss) ds' + where + (b',ds') = getMonoBind b ds + +----------------------------------------------------------------------------- +-- Group function bindings into equation groups + +getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBinding]) +-- 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 + +-- Then b' is the result of grouping more equations from ds that +-- belong with b into a single MonoBinds, and ds' is the depleted +-- list of parsed bindings. +-- +-- No AndMonoBinds or EmptyMonoBinds here; just single equations + +getMonoBind (FunMonoBind f inf mtchs loc) binds + | has_args mtchs + = go mtchs loc binds + where + go mtchs1 loc1 (RdrValBinding (FunMonoBind f2 inf2 mtchs2 loc2) : binds) + | f == f2 = go (mtchs2 ++ mtchs1) loc2 binds + -- Remember binds is reversed, so glue mtchs2 on the front + -- and use loc2 as the final location + go mtchs1 loc1 binds = (FunMonoBind f inf mtchs1 loc1, binds) + +getMonoBind bind binds = (bind, binds) + +has_args ((Match args _ _) : _) = not (null args) + -- Don't group together FunMonoBinds if they have + -- no arguments. This is necessary now that variable bindings + -- with no arguments are now treated as FunMonoBinds rather + -- than pattern bindings (tests/rename/should_fail/rnfail002). \end{code} +\begin{code} +emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive, + -- The renamer adds structure to the bindings; + -- they start life as a single giant MonoBinds + hs_tyclds = [], hs_instds = [], + hs_fixds = [], hs_defds = [], hs_fords = [], + hs_depds = [] ,hs_ruleds = [], hs_coreds = [] } + +findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a])) +findSplice ds = add emptyGroup ds + +mkGroup :: [HsDecl a] -> HsGroup a +mkGroup ds = addImpDecls emptyGroup ds + +addImpDecls :: HsGroup a -> [HsDecl a] -> HsGroup a +-- The decls are imported, and should not have a splice +addImpDecls group decls = case add group decls of + (group', Nothing) -> group' + other -> panic "addImpDecls" + +add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a])) + -- This stuff reverses the declarations (again) but it doesn't matter + +-- Base cases +add gp [] = (gp, Nothing) +add gp (SpliceD e : ds) = (gp, Just (e, ds)) + +-- Class declarations: pull out the fixity signatures to the top +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) (TyClD d : ds) + | isClassDecl d = add (gp { hs_tyclds = d : ts, + hs_fixds = [f | FixSig f <- tcdSigs d] ++ fs }) ds + | otherwise = add (gp { hs_tyclds = d : ts }) ds + +-- Signatures: fixity sigs go a different place than all others +add gp@(HsGroup {hs_fixds = ts}) (SigD (FixSig f) : ds) = add (gp {hs_fixds = f : ts}) ds +add gp@(HsGroup {hs_valds = ts}) (SigD d : ds) = add (gp {hs_valds = add_sig d ts}) ds + +-- Value declarations: use add_bind +add gp@(HsGroup {hs_valds = ts}) (ValD d : ds) = add (gp { hs_valds = add_bind d ts }) ds + +-- The rest are routine +add gp@(HsGroup {hs_instds = ts}) (InstD d : ds) = add (gp { hs_instds = d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) (DefD d : ds) = add (gp { hs_defds = d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) (ForD d : ds) = add (gp { hs_fords = d : ts }) ds +add gp@(HsGroup {hs_depds = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts})(RuleD d : ds) = add (gp { hs_ruleds = d : ts }) ds +add gp@(HsGroup {hs_coreds = ts})(CoreD d : ds) = add (gp { hs_coreds = d : ts }) ds + +add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r +add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r +\end{code} %************************************************************************ %* * @@ -388,20 +468,449 @@ cvMonoBindsAndSigs sig_cvtr fb %* * %************************************************************************ -Separate declarations into all the various kinds: \begin{code} -cvTopDecls :: RdrBinding -> [RdrNameHsDecl] -cvTopDecls bind - = let - (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind - in - (ValD (MonoBind mono_binds sigs Recursive) : top_decls) +----------------------------------------------------------------------------- +-- mkPrefixCon + +-- When parsing data declarations, we sometimes inadvertently parse +-- a constructor application as a type (eg. in data T a b = C a b `D` E a b) +-- This function splits up the type application, adds any pending +-- arguments, and converts the type constructor back into a data constructor. + +mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails) + +mkPrefixCon ty tys + = split ty tys + where + split (HsAppTy t u) ts = split t (unbangedType u : ts) + split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con -> + returnP (data_con, PrefixCon ts) + split _ _ = parseError "Illegal data/newtype declaration" + +mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails) +mkRecCon con fields + = tyConToDataCon con `thenP` \ data_con -> + returnP (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ]) + +tyConToDataCon :: RdrName -> P RdrName +tyConToDataCon tc + | isTcOcc (rdrNameOcc tc) + = returnP (setRdrNameSpace tc srcDataName) + | otherwise + = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) + +---------------------------------------------------------------------------- +-- Various Syntactic Checks + +checkInstType :: RdrNameHsType -> P RdrNameHsType +checkInstType t + = case t of + HsForAllTy tvs ctxt ty -> + checkDictTy ty [] `thenP` \ dict_ty -> + returnP (HsForAllTy tvs ctxt dict_ty) + + HsParTy ty -> checkInstType ty + + ty -> checkDictTy ty [] `thenP` \ dict_ty-> + returnP (HsForAllTy Nothing [] dict_ty) + +checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar] +checkTyVars tvs + = mapP chk tvs + where + -- Check that the name space is correct! + chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = returnP (IfaceTyVar tv k) + chk (HsTyVar tv) | isRdrTyVar tv = returnP (UserTyVar tv) + chk other = parseError "Type found where type variable expected" + +checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar]) +-- The header of a type or class decl should look like +-- (C a, D b) => T a b +-- or T a b +-- or a + b +-- etc +checkTyClHdr ty + = go ty [] + where + go (HsTyVar tc) acc + | not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs -> + returnP (tc, tvs) + go (HsOpTy t1 (HsTyOp tc) t2) acc + = checkTyVars (t1:t2:acc) `thenP` \ tvs -> + returnP (tc, tvs) + go (HsParTy ty) acc = go ty acc + go (HsAppTy t1 t2) acc = go t1 (t2:acc) + go other acc = parseError "Malformed LHS to type of class declaration" + +checkContext :: RdrNameHsType -> P RdrNameContext +checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type + = mapP checkPred ts + +checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way + = checkContext ty + +checkContext (HsTyVar t) -- Empty context shows up as a unit type () + | t == getRdrName unitTyCon = returnP [] + +checkContext t + = checkPred t `thenP` \p -> + returnP [p] + +checkPred :: RdrNameHsType -> P (HsPred 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 (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty) +checkPred ty + = go ty [] + where + go (HsTyVar t) args | not (isRdrTyVar t) + = returnP (HsClassP t args) + go (HsAppTy l r) args = go l (r:args) + go (HsParTy t) args = go t args + go _ _ = parseError "Illegal class assertion" + +checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType +checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) + = returnP (mkHsDictTy t args) +checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) +checkDictTy (HsParTy t) args = checkDictTy t args +checkDictTy _ _ = parseError "Malformed context in instance header" + + +--------------------------------------------------------------------------- +-- Checking statements in a do-expression +-- 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 +-- same comments apply for mdo as well + +checkDo = checkDoMDo "a " "'do'" +checkMDo = checkDoMDo "an " "'mdo'" + +checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct" +checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l] +checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression" +checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss `thenP` \ ss' -> + returnP (s:ss') + +--------------------------------------------------------------------------- +-- Checking Patterns. + +-- We parse patterns as expressions and check for valid patterns below, +-- converting the expression into a pattern at the same time. + +checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat +checkPattern loc e = setSrcLocP loc (checkPat e []) + +checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat] +checkPatterns loc es = mapP (checkPattern loc) es + +checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat +checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args)) +checkPat (HsApp f x) args = + checkPat x [] `thenP` \x -> + checkPat f (x:args) +checkPat e [] = case e of + EWildPat -> returnP (WildPat placeHolderType) + HsVar x | isQual x -> parseError ("Qualified variable in pattern: " ++ showRdrName x) + | otherwise -> returnP (VarPat x) + HsLit l -> returnP (LitPat l) + HsOverLit l -> returnP (NPatIn l Nothing) + ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat) + EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n) + ExprWithTySig e t -> checkPat e [] `thenP` \e -> + -- Pattern signatures are parsed as sigtypes, + -- but they aren't explicit forall points. Hence + -- we have to remove the implicit forall here. + let t' = case t of + HsForAllTy Nothing [] ty -> ty + other -> other + in + returnP (SigPatIn e t') + + -- Translate out NegApps of literals in patterns. We negate + -- the Integer here, and add back the call to 'negate' when + -- we typecheck the pattern. + -- NB. Negative *primitive* literals are already handled by + -- RdrHsSyn.mkHsNegApp + NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg)) + + OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _)) + | plus == plus_RDR + -> returnP (mkNPlusKPat n lit) + where + plus_RDR = mkUnqual varName FSLIT("+") -- Hack + + OpApp l op fix r -> checkPat l [] `thenP` \l -> + checkPat r [] `thenP` \r -> + case op of + HsVar c | isDataOcc (rdrNameOcc c) + -> returnP (ConPatIn c (InfixCon l r)) + _ -> patFail + + HsPar e -> checkPat e [] `thenP` (returnP . ParPat) + ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> + returnP (ListPat ps placeHolderType) + ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> + returnP (PArrPat ps placeHolderType) + + ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps -> + returnP (TuplePat ps b) + + RecordCon c fs -> mapP checkPatField fs `thenP` \fs -> + returnP (ConPatIn c (RecCon fs)) +-- Generics + HsType ty -> returnP (TypePat ty) + _ -> patFail + +checkPat _ _ = patFail + +checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat) +checkPatField (n,e) = checkPat e [] `thenP` \p -> + returnP (n,p) + +patFail = parseError "Parse error in pattern" + + +--------------------------------------------------------------------------- +-- Check Equation Syntax + +checkValDef + :: RdrNameHsExpr + -> Maybe RdrNameHsType + -> RdrNameGRHSs + -> SrcLoc + -> P RdrBinding + +checkValDef lhs opt_sig grhss loc + = case isFunLhs lhs [] of + Just (f,inf,es) + | isQual f + -> parseError ("Qualified name in function definition: " ++ showRdrName f) + | otherwise + -> checkPatterns loc es `thenP` \ps -> + returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc)) + + Nothing -> + checkPattern loc lhs `thenP` \lhs -> + returnP (RdrValBinding (PatMonoBind lhs grhss loc)) + +checkValSig + :: RdrNameHsExpr + -> RdrNameHsType + -> SrcLoc + -> P RdrBinding +checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrHsDecl (SigD (Sig v ty loc))) +checkValSig other ty loc = parseError "Type signature given for an expression" + +mkSigDecls :: [Sig RdrName] -> RdrBinding +mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs] + + +-- A variable binding is parsed as an RdrNameFunMonoBind. +-- See comments with HsBinds.MonoBinds + +isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr]) +isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op) + = Just (op, True, (l:r:es)) + | otherwise + = case isFunLhs l es of + Just (op', True, j : k : es') -> + Just (op', True, j : OpApp k (HsVar op) fix r : es') + _ -> Nothing +isFunLhs (HsVar f) es | not (isRdrDataCon f) + = Just (f,False,es) +isFunLhs (HsApp f e) es = isFunLhs f (e:es) +isFunLhs (HsPar e) es@(_:_) = isFunLhs e es +isFunLhs _ _ = Nothing + +--------------------------------------------------------------------------- +-- Miscellaneous utilities + +checkPrecP :: Int -> P Int +checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i + | otherwise = parseError "Precedence out of range" + +mkRecConstrOrUpdate + :: RdrNameHsExpr + -> RdrNameHsRecordBinds + -> P RdrNameHsExpr + +mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c + = returnP (RecordCon c fs) +mkRecConstrOrUpdate exp fs@(_:_) + = returnP (RecordUpd exp fs) +mkRecConstrOrUpdate _ _ + = parseError "Empty record update" + +----------------------------------------------------------------------------- +-- utilities for foreign declarations + +-- supported calling conventions +-- +data CallConv = CCall CCallConv -- ccall or stdcall + | DNCall -- .NET + +-- construct a foreign import declaration +-- +mkImport :: CallConv + -> Safety + -> (FastString, RdrName, RdrNameHsType) + -> SrcLoc + -> P RdrNameHsDecl +mkImport (CCall cconv) safety (entity, v, ty) loc = + parseCImport entity cconv safety v `thenP` \importSpec -> + returnP $ ForD (ForeignImport v ty importSpec False loc) +mkImport (DNCall ) _ (entity, v, ty) loc = + parseDImport entity `thenP` \ spec -> + returnP $ ForD (ForeignImport v ty (DNImport spec) False loc) + +-- parse the entity string of a foreign import declaration for the `ccall' or +-- `stdcall' calling convention' +-- +parseCImport :: FastString + -> CCallConv + -> Safety + -> RdrName + -> P ForeignImport +parseCImport entity cconv safety v + -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak + | entity == FSLIT ("dynamic") = + returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget) + | entity == FSLIT ("wrapper") = + returnP $ CImport cconv safety nilFS nilFS CWrapper + | otherwise = parse0 (unpackFS entity) + where + -- using the static keyword? + parse0 (' ': rest) = parse0 rest + parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest + parse0 rest = parse1 rest + -- check for header file name + parse1 "" = parse4 "" nilFS False nilFS + parse1 (' ':rest) = parse1 rest + parse1 str@('&':_ ) = parse2 str nilFS + parse1 str@('[':_ ) = parse3 str nilFS False + parse1 str + | ".h" `isSuffixOf` first = parse2 rest (mkFastString first) + | otherwise = parse4 str nilFS False nilFS + where + (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str + -- check for address operator (indicating a label import) + parse2 "" header = parse4 "" header False nilFS + parse2 (' ':rest) header = parse2 rest header + parse2 ('&':rest) header = parse3 rest header True + parse2 str@('[':_ ) header = parse3 str header False + parse2 str header = parse4 str header False nilFS + -- check for library object name + parse3 (' ':rest) header isLbl = parse3 rest header isLbl + parse3 ('[':rest) header isLbl = + case break (== ']') rest of + (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib) + _ -> parseError "Missing ']' in entity" + parse3 str header isLbl = parse4 str header isLbl nilFS + -- check for name of C function + parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib + parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib + parse4 str header isLbl lib + | all (== ' ') rest = build (mkFastString first) header isLbl lib + | otherwise = parseError "Malformed entity string" + where + (first, rest) = break (== ' ') str + -- + build cid header False lib = returnP $ + CImport cconv safety header lib (CFunction (StaticTarget cid)) + build cid header True lib = returnP $ + CImport cconv safety header lib (CLabel cid ) + +-- +-- Unravel a dotnet spec string. +-- +parseDImport :: FastString -> P DNCallSpec +parseDImport entity = parse0 comps + where + comps = words (unpackFS entity) + + parse0 [] = d'oh + parse0 (x : xs) + | x == "static" = parse1 True xs + | otherwise = parse1 False (x:xs) + + parse1 _ [] = d'oh + parse1 isStatic (x:xs) + | x == "method" = parse2 isStatic DNMethod xs + | x == "field" = parse2 isStatic DNField xs + | x == "ctor" = parse2 isStatic DNConstructor xs + parse1 isStatic xs = parse2 isStatic DNMethod xs + + parse2 _ _ [] = d'oh + parse2 isStatic kind (('[':x):xs) = + case x of + [] -> d'oh + vs | last vs == ']' -> parse3 isStatic kind (init vs) xs + parse2 isStatic kind xs = parse3 isStatic kind "" xs + + parse3 isStatic kind assem [x] = + returnP (DNCallSpec isStatic kind assem x + -- these will be filled in once known. + (error "FFI-dotnet-args") + (error "FFI-dotnet-result")) + parse3 _ _ _ _ = d'oh + + d'oh = parseError "Malformed entity string" + +-- construct a foreign export declaration +-- +mkExport :: CallConv + -> (FastString, RdrName, RdrNameHsType) + -> SrcLoc + -> P RdrNameHsDecl +mkExport (CCall cconv) (entity, v, ty) loc = returnP $ + ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc) where - go acc RdrNullBind = acc - go acc (RdrAndBindings b1 b2) = go (go acc b1) b2 - go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs) - go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs) - go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs) - go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs) + entity' | nullFastString entity = mkExtName v + | otherwise = entity +mkExport DNCall (entity, v, ty) loc = + parseError "Foreign export is not yet supported for .NET" + +-- Supplying the ext_name in a foreign decl is optional; if it +-- isn't there, the Haskell name is assumed. Note that no transformation +-- 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)) + +-- --------------------------------------------------------------------------- +-- Make the export list for an interface + +mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo] +mkIfaceExports decls = map getExport decls + where getExport d = case d of + TyData{} -> tc_export + ClassDecl{} -> tc_export + _other -> var_export + where + tc_export = AvailTC (rdrNameOcc (tcdName d)) + (map (rdrNameOcc.fst) (tyClDeclNames d)) + var_export = Avail (rdrNameOcc (tcdName d)) \end{code} + + +----------------------------------------------------------------------------- +-- Misc utils + +\begin{code} +showRdrName :: RdrName -> String +showRdrName r = showSDoc (ppr r) + +parseError :: String -> P a +parseError s = + getSrcLocP `thenP` \ loc -> + failMsgP (hcat [ppr loc, text ": ", text s]) +\end{code} +