X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=a9557914129761cb079fa41ec8ec94821c061e3f;hb=b785be47556f5c1128e76355471fdb5de0a1ee64;hp=4ef778a561c1a83ad2b40e6f9c6dac29b239ddc1;hpb=31175885baab218934c8faddb0e067e6f7616318;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 4ef778a..a955791 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -1,157 +1,73 @@ % -% (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 ( - RdrNameArithSeqInfo, - RdrNameBangType, - RdrNameClassOpSig, - RdrNameConDecl, - RdrNameConDetails, - RdrNameContext, - RdrNameDefaultDecl, - RdrNameForeignDecl, - RdrNameCoreDecl, - RdrNameGRHS, - RdrNameGRHSs, - RdrNameHsBinds, - RdrNameHsDecl, - RdrNameHsExpr, - RdrNameHsModule, - RdrNameIE, - RdrNameImportDecl, - RdrNameInstDecl, - RdrNameMatch, - RdrNameMonoBinds, - RdrNamePat, - RdrNameHsType, - RdrNameHsTyVar, - RdrNameSig, - RdrNameStmt, - RdrNameTyClDecl, - RdrNameRuleDecl, - RdrNameRuleBndr, - RdrNameDeprecation, - RdrNameHsRecordBinds, - RdrNameFixitySig, - - RdrBinding(..), - RdrMatch(..), - - extractHsTyRdrNames, extractHsTyRdrTyVars, - extractHsCtxtRdrTyVars, extractGenericPatTyVars, + extractHsTyRdrTyVars, + extractHsRhoRdrTyVars, extractGenericPatTyVars, - mkHsOpApp, mkClassDecl, mkClassOpSigDM, - mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, - mkHsDo, mkHsSplice, mkSigDecls, - mkTyData, mkPrefixCon, mkRecCon, + mkHsOpApp, mkClassDecl, + mkHsNegApp, mkHsIntegral, mkHsFractional, + mkHsDo, mkHsSplice, + mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp - mkIfaceExports, -- :: [RdrNameTyClDecl] -> [RdrExportItem] - cvBinds, - cvMonoBindsAndSigs, + cvBindGroup, + cvBindsAndSigs, cvTopDecls, - cvClassOpSig, - findSplice, addImpDecls, emptyGroup, mkGroup, + findSplice, mkGroup, -- Stuff to do with Foreign declarations - , CallConv(..) - , mkImport -- CallConv -> Safety + CallConv(..), + mkImport, -- CallConv -> Safety -- -> (FastString, RdrName, RdrNameHsType) - -- -> SrcLoc -- -> P RdrNameHsDecl - , mkExport -- CallConv + mkExport, -- CallConv -- -> (FastString, RdrName, RdrNameHsType) - -- -> SrcLoc -- -> 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 - , 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 + 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, mkRdrUnqual, mkUnqual, rdrNameOcc, - isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, +import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, + 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 BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec ) +import Lexer ( P, failSpanMsgP ) +import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), - DNCallSpec(..)) -import OccName ( dataName, varName, isDataOcc, isTcOcc, occNameUserString, - mkDefaultMethodOcc, mkVarOcc ) + DNCallSpec(..), DNKind(..), CLabelString ) +import OccName ( srcDataName, varName, isDataOcc, isTcOcc, + occNameString ) import SrcLoc -import CStrings ( CLabelString ) -import List ( isSuffixOf, nub ) +import OrdList ( OrdList, fromOL ) +import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable import FastString import Panic -\end{code} - -%************************************************************************ -%* * -\subsection{Type synonyms} -%* * -%************************************************************************ - -\begin{code} -type RdrNameArithSeqInfo = ArithSeqInfo RdrName -type RdrNameBangType = BangType RdrName -type RdrNameClassOpSig = Sig RdrName -type RdrNameConDecl = ConDecl RdrName -type RdrNameConDetails = HsConDetails RdrName RdrNameBangType -type RdrNameContext = HsContext RdrName -type RdrNameHsDecl = HsDecl RdrName -type RdrNameDefaultDecl = DefaultDecl RdrName -type RdrNameForeignDecl = ForeignDecl RdrName -type RdrNameCoreDecl = CoreDecl RdrName -type RdrNameGRHS = GRHS RdrName -type RdrNameGRHSs = GRHSs RdrName -type RdrNameHsBinds = HsBinds RdrName -type RdrNameHsExpr = HsExpr RdrName -type RdrNameHsModule = HsModule RdrName -type RdrNameIE = IE RdrName -type RdrNameImportDecl = ImportDecl RdrName -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 -type RdrNameTyClDecl = TyClDecl RdrName - -type RdrNameRuleBndr = RuleBndr RdrName -type RdrNameRuleDecl = RuleDecl RdrName -type RdrNameDeprecation = DeprecDecl RdrName -type RdrNameFixitySig = FixitySig RdrName - -type RdrNameHsRecordBinds = HsRecordBinds RdrName +import List ( isSuffixOf, nubBy ) \end{code} @@ -161,60 +77,60 @@ type RdrNameHsRecordBinds = HsRecordBinds RdrName %* * %************************************************************************ -@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} -extractHsTyRdrNames :: RdrNameHsType -> [RdrName] -extractHsTyRdrNames ty = nub (extract_ty ty []) - -extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName] -extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty [])) - -extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName] -extractHsCtxtRdrNames ty = nub (extract_ctxt ty []) -extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName] -extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty) - -extract_ctxt ctxt acc = foldr extract_pred acc ctxt - -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 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 (HsNumTy num) acc = acc -extract_ty (HsKindSig ty k) acc = extract_ty ty acc -extract_ty (HsForAllTy (Just tvs) ctxt ty) - acc = acc ++ - (filter (`notElem` locals) $ - extract_ctxt ctxt (extract_ty ty [])) - where - locals = hsTyVarNames tvs - -extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName] +extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName] +extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty []) + +extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName] +-- This one takes the context and tau-part of a +-- sigma type and returns their free type variables +extractHsRhoRdrTyVars ctxt ty + = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty []) + +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 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 -- possibly-generic bindings in a class declaration extractGenericPatTyVars binds - = filter isRdrTyVar (nub (get binds [])) + = nubBy eqLocated (foldrBag get [] binds) where - get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc) - get (FunMonoBind _ _ ms _) acc = foldr get_m 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 (TypePat ty : _) _ _) acc = extract_ty ty acc - get_m other acc = acc + get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc + get_m other acc = acc \end{code} @@ -235,104 +151,34 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. *** See "THE NAMING STORY" in HsDecls **** \begin{code} -mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc - = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars, - tcdFDs = fds, tcdSigs = 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, +mkClassDecl (cxt, cname, tyvars) fds sigs mbinds + = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars, + tcdFDs = fds, + tcdSigs = sigs, + tcdMeths = mbinds + } + +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, - tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing } - -mkClassOpSigDM op ty loc - = ClassOpSig op (DefMeth dm_rn) ty loc - where - dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op)) + tcdKindSig = ksig, tcdDerivs = maybe_deriv } \end{code} \begin{code} -mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr --- If the type checker sees (negate 3#) it will barf, because negate +mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName +-- RdrName 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! - -mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i)) -mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i)) -mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) -mkHsNegApp expr = NegApp expr placeHolderName -\end{code} - -A useful function for building @OpApps@. The operator is always a -variable, and we don't know the fixity yet. - -\begin{code} -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} - -%************************************************************************ -%* * -\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 RdrNameMonoBinds - - -- The remainder all fit into the main HsDecl form - | RdrHsDecl RdrNameHsDecl -\end{code} - -\begin{code} -data RdrMatch - = RdrMatch - [RdrNamePat] - (Maybe RdrNameHsType) - RdrNameGRHSs +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) noSyntaxExpr \end{code} %************************************************************************ %* * -\subsection[cvDecls]{Convert various top-level declarations} -%* * -%************************************************************************ - -We make a point not to throw any user-pragma ``sigs'' at -these conversion functions: - -\begin{code} -cvClassOpSig :: RdrNameSig -> RdrNameSig -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.} +\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.} %* * %************************************************************************ @@ -342,45 +188,39 @@ analyser. \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 +-- | Groups together bindings for a single function +cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName] +cvTopDecls decls = go (fromOL 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 + 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) -> HsValBinds RdrName +cvBindGroup binding + = case (cvBindsAndSigs binding) of { (mbs, sigs) -> + ValBindsIn mbs sigs } -cvMonoBindsAndSigs :: [RdrBinding] -> (RdrNameMonoBinds, [RdrNameSig]) --- Input bindings are in *reverse* order, --- and contain just value bindings and signatuers - -cvMonoBindsAndSigs fb - = go (EmptyMonoBinds, []) 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 (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 + 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 :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [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 @@ -391,75 +231,84 @@ getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBindin -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (FunMonoBind f inf mtchs loc) binds +getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _) _)) 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) + 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)) placeHolderNames), binds) + -- Reverse the final matches, to get it back in the right order getMonoBind bind binds = (bind, binds) -has_args ((Match args _ _) : _) = not (null args) - -- Don't group together FunMonoBinds if they have +has_args ((L _ (Match args _ _)) : _) = not (null args) + -- Don't group together FunBinds if they have -- no arguments. This is necessary now that variable bindings - -- with no arguments are now treated as FunMonoBinds rather + -- with no arguments are now treated as FunBinds 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 :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) +findSplice ds = addl emptyRdrGroup ds -findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a])) -findSplice ds = add emptyGroup ds +mkGroup :: [LHsDecl a] -> HsGroup a +mkGroup ds = addImpDecls emptyRdrGroup ds -mkGroup :: [HsDecl a] -> HsGroup a -mkGroup ds = addImpDecls emptyGroup ds - -addImpDecls :: HsGroup a -> [HsDecl a] -> HsGroup a +addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a -- The decls are imported, and should not have a splice -addImpDecls group decls = case add group decls of +addImpDecls group decls = case addl group decls of (group', Nothing) -> group' other -> panic "addImpDecls" -add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a])) +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 -add gp [] = (gp, Nothing) -add gp (SpliceD e : ds) = (gp, Just (e, ds)) +addl gp [] = (gp, Nothing) +addl gp (L l d : ds) = add gp l d ds + + +add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a] + -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) + +add gp l (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 +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds + | isClassDecl d = + let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in + addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds + | otherwise = + addl (gp { hs_tyclds = L l 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 +add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds + = addl (gp {hs_fixds = L l f : ts}) ds +add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds + = addl (gp {hs_valds = add_sig (L l 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 +add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds + = addl (gp { hs_valds = add_bind (L l 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 +add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds + = addl (gp { hs_instds = L l d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds + = addl (gp { hs_defds = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds + = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds + = addl (gp { hs_depds = L l d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds + = addl (gp { hs_ruleds = L l d : ts }) ds + +add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs +add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) \end{code} %************************************************************************ @@ -478,267 +327,358 @@ add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r -- 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 :: LHsType RdrName -> [LBangType RdrName] + -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) 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 + 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" + +mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)] + -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) +mkRecCon (L loc con) fields + = do data_con <- tyConToDataCon loc con + return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ]) + +tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) +tyConToDataCon loc tc | isTcOcc (rdrNameOcc tc) - = returnP (setRdrNameSpace tc dataName) + = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise - = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) + = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) ---------------------------------------------------------------------------- -- Various Syntactic Checks -checkInstType :: RdrNameHsType -> P RdrNameHsType -checkInstType t +checkInstType :: LHsType RdrName -> P (LHsType RdrName) +checkInstType (L l t) = case t of - HsForAllTy tvs ctxt ty -> - checkDictTy ty [] `thenP` \ dict_ty -> - returnP (HsForAllTy tvs ctxt dict_ty) + HsForAllTy exp tvs ctxt ty -> do + dict_ty <- checkDictTy ty + return (L l (HsForAllTy exp tvs ctxt dict_ty)) HsParTy ty -> checkInstType ty - ty -> checkDictTy ty [] `thenP` \ dict_ty-> - returnP (HsForAllTy Nothing [] dict_ty) + ty -> do dict_ty <- checkDictTy (L l ty) + return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty)) -checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar] -checkTyVars tvs = mapP chk tvs - where - chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k) - chk (HsTyVar tv) = returnP (UserTyVar tv) - chk other = parseError "Type found where type variable expected" - -checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar]) +checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName] +checkTyVars tvs + = mapM chk tvs + where + -- Check that the name space is correct! + chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) + | isRdrTyVar tv = return (L l (KindedTyVar tv k)) + chk (L l (HsTyVar tv)) + | isRdrTyVar tv = return (L l (UserTyVar tv)) + 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 -- (C a, D b) => T a b -- or T a b -- or a + b -- etc -checkTyClHdr ty - = go ty [] +checkTyClHdr (L l cxt) ty + = do (tc, tvs) <- gol ty [] + mapM_ chk_pred cxt + return (L l cxt, tc, tvs) 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) + gol (L l ty) acc = go l ty acc + + go l (HsTyVar tc) acc + | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs -> + return (L l tc, tvs) + go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs -> + return (tc, tvs) + go l (HsParTy ty) acc = gol ty acc + go l (HsAppTy t1 t2) acc = gol t1 (t2:acc) + go l other acc = parseError l "Malformed LHS to type of class declaration" + + -- The predicates in a type or class decl must all + -- be HsClassPs. They need not all be type variables, + -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m + chk_pred (L l (HsClassP _ args)) = return () + chk_pred (L l _) + = parseError l "Malformed context in type or class declaration" + + +checkContext :: LHsType RdrName -> P (LHsContext RdrName) +checkContext (L l t) + = check t + where + check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type + = do ctx <- mapM checkPred ts + return (L l ctx) + + check (HsParTy ty) -- to be sure HsParTy doesn't get into the way + = check (unLoc ty) + + check (HsTyVar t) -- Empty context shows up as a unit type () + | t == getRdrName unitTyCon = return (L l []) + + check t + = do p <- checkPred (L l t) + return (L l [p]) + + +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 (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty) -checkPred ty - = go ty [] +checkPred (L spn (HsPredTy (HsIParam n ty))) + = return (L spn (HsIParam n ty)) +checkPred (L spn ty) + = check spn 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" + checkl (L l ty) args = check l ty args -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" + 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 [] + where + 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" --------------------------------------------------------------------------- -- 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 +-- (b) returns it separately -- 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') - ---------------------------------------------------------------------------- +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 ([], e) + check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++ + " construct must be an expression") + check (s:ss) = do + (ss',e') <- check ss + return ((s:ss'),e') + +-- ------------------------------------------------------------------------- -- 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 -> 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)) +checkPattern :: LHsExpr RdrName -> P (LPat RdrName) +checkPattern e = checkLPat e + +checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName] +checkPatterns es = mapM checkPattern es + +checkLPat :: LHsExpr RdrName -> P (LPat RdrName) +checkLPat e@(L l _) = checkPat l e [] + +checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName) +checkPat loc (L l (HsVar c)) args + | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) +checkPat loc (L _ (HsApp f x)) args = do + x <- checkLPat x + checkPat loc f (x:args) +checkPat loc (L _ e) [] = do + p <- checkAPat loc e + return (L loc p) +checkPat loc pat _some_args + = patFail loc + +checkAPat loc e = case e of + EWildPat -> return (WildPat placeHolderType) + HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: " + ++ showRdrName x) + | otherwise -> return (VarPat x) + HsLit l -> return (LitPat l) + + -- Overloaded numeric patterns (e.g. f 0 x = x) + -- 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 (mkNPat pos_lit Nothing) + NegApp (L _ (HsOverLit pos_lit)) _ + -> return (mkNPat pos_lit (Just noSyntaxExpr)) + + ELazyPat e -> checkLPat e >>= (return . LazyPat) + EAsPat n e -> checkLPat e >>= (return . AsPat n) + ExprWithTySig e t -> checkLPat e >>= \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 + L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty + other -> other + in + return (SigPatIn e t') + + -- n+k patterns + OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ + (L _ (HsOverLit lit@(HsIntegral _ _))) + | plus == plus_RDR + -> return (mkNPlusKPat (L nloc n) lit) + where + plus_RDR = mkUnqual varName FSLIT("+") -- Hack + + OpApp l op fix r -> checkLPat l >>= \l -> + checkLPat r >>= \r -> + case op of + L cl (HsVar c) | isDataOcc (rdrNameOcc c) + -> return (ConPatIn (L cl c) (InfixCon l r)) + _ -> patFail loc + + HsPar e -> checkLPat e >>= (return . ParPat) + ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps -> + return (ListPat ps placeHolderType) + ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps -> + return (PArrPat ps placeHolderType) + + ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps -> + return (TuplePat ps b) + + RecordCon c _ fs -> mapM checkPatField fs >>= \fs -> + return (ConPatIn c (RecCon fs)) -- Generics - HsType ty -> returnP (TypePat ty) - _ -> patFail - -checkPat _ _ = patFail + HsType ty -> return (TypePat ty) + _ -> patFail loc -checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat) -checkPatField (n,e) = checkPat e [] `thenP` \p -> - returnP (n,p) +checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName) +checkPatField (n,e) = do + p <- checkLPat e + return (n,p) -patFail = parseError "Parse error in pattern" +patFail loc = parseError loc "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) -> - 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)) + :: LHsExpr RdrName + -> Maybe (LHsType RdrName) + -> Located (GRHSs RdrName) + -> P (HsBind RdrName) + +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 + let match_span = combineSrcSpans (getLoc lhs) rhs_span + 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 placeHolderNames) 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 + :: LHsExpr RdrName + -> LHsType RdrName + -> P (Sig RdrName) +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 "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. + +isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName] + -> Maybe (Located RdrName, Bool, [LHsExpr RdrName]) +isFunLhs (L loc e) = isFunLhs' loc e + where + isFunLhs' loc (HsVar f) es + | not (isRdrDataCon f) = Just (L loc f, False, es) + isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es) + isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es + isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es + | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es)) + | otherwise = + case isFunLhs l es of + Just (op', True, j : k : es') -> + Just (op', True, + j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es') + _ -> Nothing + isFunLhs' _ _ _ = Nothing --------------------------------------------------------------------------- -- Miscellaneous utilities -checkPrecP :: Int -> P Int -checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i - | otherwise = parseError "Precedence out of range" +checkPrecP :: Located Int -> P Int +checkPrecP (L l i) + | 0 <= i && i <= maxPrecedence = return i + | otherwise = parseError l "Precedence out of range" mkRecConstrOrUpdate - :: RdrNameHsExpr - -> RdrNameHsRecordBinds - -> P RdrNameHsExpr + :: LHsExpr RdrName + -> SrcSpan + -> HsRecordBinds RdrName + -> P (HsExpr RdrName) + +mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c + = return (RecordCon (L l c) noPostTcExpr fs) +mkRecConstrOrUpdate exp loc 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 -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 @@ -752,29 +692,29 @@ data CallConv = CCall CCallConv -- ccall or stdcall -- 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 = - returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc) + -> (Located FastString, Located RdrName, LHsType RdrName) + -> P (HsDecl RdrName) +mkImport (CCall cconv) safety (entity, v, ty) = do + importSpec <- parseCImport entity cconv safety v + return (ForD (ForeignImport v ty importSpec False)) +mkImport (DNCall ) _ (entity, v, ty) = do + spec <- parseDImport entity + return $ ForD (ForeignImport v ty (DNImport spec) False) -- parse the entity string of a foreign import declaration for the `ccall' or -- `stdcall' calling convention' -- -parseCImport :: FastString +parseCImport :: Located FastString -> CCallConv -> Safety - -> RdrName + -> Located RdrName -> P ForeignImport -parseCImport entity cconv safety v +parseCImport (L loc 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) + return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget) | entity == FSLIT ("wrapper") = - returnP $ CImport cconv safety nilFS nilFS CWrapper + return $ CImport cconv safety nilFS nilFS CWrapper | otherwise = parse0 (unpackFS entity) where -- using the static keyword? @@ -802,59 +742,80 @@ parseCImport entity cconv safety v parse3 ('[':rest) header isLbl = case break (== ']') rest of (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib) - _ -> parseError "Missing ']' in entity" + _ -> parseError loc "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 "" header isLbl lib = build (mkExtName (unLoc 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" + | otherwise = parseError loc "Malformed entity string" where (first, rest) = break (== ' ') str -- - build cid header False lib = returnP $ + build cid header False lib = return $ CImport cconv safety header lib (CFunction (StaticTarget cid)) - build cid header True lib = returnP $ + build cid header True lib = return $ CImport cconv safety header lib (CLabel cid ) +-- +-- Unravel a dotnet spec string. +-- +parseDImport :: Located FastString -> P DNCallSpec +parseDImport (L loc 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] = + return (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 loc "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) + -> (Located FastString, Located RdrName, LHsType RdrName) + -> P (HsDecl RdrName) +mkExport (CCall cconv) (L loc entity, v, ty) = return $ + ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False) where - entity' | nullFastString entity = mkExtName v - | otherwise = entity -mkExport DNCall (entity, v, ty) loc = - parseError "Foreign export is not yet supported for .NET" + 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" -- 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)) +mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) \end{code} @@ -862,9 +823,9 @@ mkIfaceExports decls = map getExport decls -- Misc utils \begin{code} -parseError :: String -> P a -parseError s = - getSrcLocP `thenP` \ loc -> - failMsgP (hcat [ppr loc, text ": ", text s]) -\end{code} +showRdrName :: RdrName -> String +showRdrName r = showSDoc (ppr r) +parseError :: SrcSpan -> String -> P a +parseError span s = failSpanMsgP span s +\end{code}