RdrNameContext,
RdrNameDefaultDecl,
RdrNameForeignDecl,
- RdrNameCoreDecl,
RdrNameGRHS,
RdrNameGRHSs,
RdrNameHsBinds,
+ RdrNameHsCmd,
+ RdrNameHsCmdTop,
RdrNameHsDecl,
RdrNameHsExpr,
RdrNameHsModule,
main_RDR_Unqual,
- extractHsTyRdrNames, extractHsTyRdrTyVars,
- extractHsCtxtRdrTyVars, extractGenericPatTyVars,
+ extractHsTyRdrTyVars,
+ extractHsRhoRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl, mkClassOpSigDM,
+ mkHsOpApp, mkClassDecl,
mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
mkHsDo, mkHsSplice, mkSigDecls,
mkTyData, mkPrefixCon, mkRecCon,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
- mkIfaceExports, -- :: [RdrNameTyClDecl] -> [RdrExportItem]
+ mkBootIface,
cvBinds,
cvMonoBindsAndSigs,
cvTopDecls,
- cvClassOpSig,
findSplice, addImpDecls, emptyGroup, mkGroup,
-- Stuff to do with Foreign declarations
#include "HsVersions.h"
import HsSyn -- Lots of it
+import IfaceType
+import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache )
+import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) )
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 )
+ setRdrNameSpace, rdrNameModule )
+import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
+import Lexer ( P, setSrcLocFor, getSrcLoc, failLocMsgP )
+import HscTypes ( GenAvailInfo(..) )
+import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
- DNCallSpec(..))
-import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString,
- mkDefaultMethodOcc, mkVarOcc )
+ DNCallSpec(..), DNKind(..))
+import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
+ occNameUserString, mkVarOcc, isValOcc )
+import BasicTypes ( initialVersion )
+import TyCon ( DataConDetails(..) )
+import Module ( ModuleName )
import SrcLoc
import CStrings ( CLabelString )
+import CmdLineOpts ( opt_InPackage )
import List ( isSuffixOf, nub )
import Outputable
import FastString
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 RdrNameHsCmd = HsCmd RdrName
+type RdrNameHsCmdTop = HsCmdTop RdrName
type RdrNameHsModule = HsModule RdrName
type RdrNameIE = IE RdrName
type RdrNameImportDecl = ImportDecl RdrName
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)
+extractHsRhoRdrTyVars :: HsContext RdrName -> RdrNameHsType -> [RdrName]
+-- This one takes the context and tau-part of a
+-- sigma type and returns their free type variables
+extractHsRhoRdrTyVars ctxt ty = nub $ filter isRdrTyVar $
+ extract_ctxt ctxt (extract_ty 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)
+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 (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsParTy ty) acc = extract_ty ty acc
+extract_ty (HsNumTy num) acc = acc
+extract_ty (HsKindSig ty k) acc = extract_ty ty acc
+extract_ty (HsForAllTy exp [] cx ty) acc = extract_ctxt cx (extract_ty ty acc)
+extract_ty (HsForAllTy exp tvs cx ty)
acc = acc ++
(filter (`notElem` locals) $
- extract_ctxt ctxt (extract_ty ty []))
+ extract_ctxt cx (extract_ty ty []))
where
locals = hsTyVarNames tvs
\begin{code}
mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
= ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
- tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
+ 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,
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))
+ tcdDerivs = maybe, tcdLoc = src }
\end{code}
\begin{code}
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
+mkHsNegApp expr = NegApp expr placeHolderName
\end{code}
A useful function for building @OpApps@. The operator is always a
%************************************************************************
%* *
+ Hi-boot files
+%* *
+%************************************************************************
+
+mkBootIface, and its boring helper functions, have two purposes:
+a) HsSyn to IfaceSyn. The parser parses the former, but we're reading
+ an hi-boot file, and interfaces consist of the latter
+b) Convert unqualifed names from the "current module" to qualified Orig
+ names. E.g.
+ module This where
+ foo :: GHC.Base.Int -> GHC.Base.Int
+ becomes
+ This.foo :: GHC.Base.Int -> GHC.Base.Int
+
+It assumes that everything is well kinded, of course.
+
+\begin{code}
+mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
+-- Make the ModIface for a hi-boot file
+-- The decls are of very limited form
+mkBootIface mod decls
+ = (emptyModIface opt_InPackage mod) {
+ mi_boot = True,
+ mi_exports = [(mod, map mk_export decls')],
+ mi_decls = decls_w_vers,
+ mi_ver_fn = mkIfaceVerCache decls_w_vers }
+ where
+ decls' = map hsIfaceDecl decls
+ decls_w_vers = repeat initialVersion `zip` decls'
+
+ -- hi-boot declarations don't (currently)
+ -- expose constructors or class methods
+ mk_export decl | isValOcc occ = Avail occ
+ | otherwise = AvailTC occ [occ]
+ where
+ occ = ifName decl
+
+
+hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
+ -- Change to Iface syntax, and replace unqualified names with
+ -- qualified Orig names from this module. Reason: normal
+ -- iface files have everything fully qualified, so it's convenient
+ -- for hi-boot files to look the same
+ --
+ -- NB: no constructors or class ops to worry about
+hsIfaceDecl (SigD (Sig name ty _))
+ = IfaceId { ifName = rdrNameOcc name,
+ ifType = hsIfaceType ty,
+ ifIdInfo = NoInfo }
+
+hsIfaceDecl (TyClD decl@(TySynonym {}))
+ = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifSynRhs = hsIfaceType (tcdSynRhs decl),
+ ifVrcs = [] }
+
+hsIfaceDecl (TyClD decl@(TyData {}))
+ = IfaceData { ifND = tcdND decl,
+ ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifCtxt = hsIfaceCtxt (tcdCtxt decl),
+ ifCons = Unknown, 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
+
+hsIfaceDecl (TyClD decl@(ClassDecl {}))
+ = IfaceClass { ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifCtxt = hsIfaceCtxt (tcdCtxt decl),
+ ifFDs = hsIfaceFDs (tcdFDs decl),
+ ifSigs = [], -- Is this right??
+ ifRec = NonRecursive, ifVrcs = [] }
+
+hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
+
+hsIfaceName rdr_name -- Qualify unqualifed occurrences
+ -- with the module name
+ | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
+ | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+
+hsIfaceType :: HsType RdrName -> IfaceType
+hsIfaceType (HsForAllTy exp tvs cxt ty)
+ = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
+ where
+ rho = foldr (IfaceFunTy . IfacePredTy . hsIfacePred) tau cxt
+ tau = hsIfaceType ty
+ tvs' = case exp of
+ Explicit -> tvs
+ Implicit -> map UserTyVar (extractHsRhoRdrTyVars cxt ty)
+
+hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
+hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
+hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceType t1) (hsIfaceType t2)
+hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceType t]
+hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceType t]
+hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceTypes ts)
+hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar tc) (hsIfaceTypes [t1, t2])
+hsIfaceType (HsParTy t) = hsIfaceType t
+hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
+hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p)
+hsIfaceType (HsKindSig t _) = hsIfaceType t
+
+-----------
+hsIfaceTypes tys = map hsIfaceType tys
+
+-----------
+hsIfaceCtxt :: [HsPred RdrName] -> [IfacePredType]
+hsIfaceCtxt ctxt = map hsIfacePred ctxt
+
+-----------
+hsIfacePred :: HsPred RdrName -> IfacePredType
+hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceTypes ts)
+hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceType t)
+
+-----------
+hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
+hs_tc_app (HsAppTy t1 t2) args = hs_tc_app t1 (hsIfaceType t2 : args)
+hs_tc_app (HsTyVar n) args
+ | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
+ | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
+hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
+
+-----------
+hsIfaceTvs tvs = map hsIfaceTv tvs
+
+-----------
+hsIfaceTv (UserTyVar n) = (rdrNameOcc n, IfaceLiftedTypeKind)
+hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k)
+
+-----------
+hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
+hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
+ | (xs,ys) <- fds ]
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection[rdrBinding]{Bindings straight out of the parser}
%* *
%************************************************************************
%************************************************************************
%* *
-\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.}
%* *
%************************************************************************
-- they start life as a single giant MonoBinds
hs_tyclds = [], hs_instds = [],
hs_fixds = [], hs_defds = [], hs_fords = [],
- hs_depds = [] ,hs_ruleds = [], hs_coreds = [] }
+ hs_depds = [] ,hs_ruleds = [] }
findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
findSplice ds = add emptyGroup 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
= 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 (HsTyVar tc) ts = tyConToDataCon tc >>= \ data_con ->
+ return (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 con >>= \ data_con ->
+ return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
tyConToDataCon :: RdrName -> P RdrName
tyConToDataCon tc
| isTcOcc (rdrNameOcc tc)
- = returnP (setRdrNameSpace tc srcDataName)
+ = return (setRdrNameSpace tc srcDataName)
| otherwise
= parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
checkInstType :: RdrNameHsType -> P RdrNameHsType
checkInstType t
= case t of
- HsForAllTy tvs ctxt ty ->
- checkDictTy ty [] `thenP` \ dict_ty ->
- returnP (HsForAllTy tvs ctxt dict_ty)
+ HsForAllTy exp tvs ctxt ty ->
+ checkDictTy ty [] >>= \ dict_ty ->
+ return (HsForAllTy exp tvs ctxt dict_ty)
HsParTy ty -> checkInstType ty
- ty -> checkDictTy ty [] `thenP` \ dict_ty->
- returnP (HsForAllTy Nothing [] dict_ty)
+ ty -> checkDictTy ty [] >>= \ dict_ty->
+ return (HsForAllTy Implicit [] [] dict_ty)
checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar]
checkTyVars tvs
- = mapP chk tvs
+ = mapM 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 (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = return (KindedTyVar tv k)
+ chk (HsTyVar tv) | isRdrTyVar tv = return (UserTyVar tv)
chk other = parseError "Type found where type variable expected"
-checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
+checkTyClHdr :: RdrNameContext -> RdrNameHsType -> P (RdrNameContext, 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 []
+checkTyClHdr cxt ty
+ = go ty [] >>= \ (tc, tvs) ->
+ mapM chk_pred cxt >>= \ _ ->
+ return (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)
+ | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
+ return (tc, tvs)
+ go (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
+ return (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"
+ -- 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 (HsClassP _ args) = return ()
+ chk_pred pred = parseError "Malformed context in type or class declaration"
+
+
checkContext :: RdrNameHsType -> P RdrNameContext
checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
- = mapP checkPred ts
+ = mapM 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 []
+ | t == getRdrName unitTyCon = return []
checkContext t
- = checkPred t `thenP` \p ->
- returnP [p]
+ = checkPred t >>= \p ->
+ return [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 (HsPredTy (HsIParam n ty)) = return (HsIParam n ty)
checkPred ty
= go ty []
where
go (HsTyVar t) args | not (isRdrTyVar t)
- = returnP (HsClassP t args)
+ = return (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)
+ = return (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"
checkMDo = checkDoMDo "an " "'mdo'"
checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct"
-checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l]
+checkDoMDo _ _ [ExprStmt e _ l] = return [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 pre nm (s:ss) = checkDoMDo pre nm ss >>= \ ss' ->
+ return (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 [])
+checkPattern loc e = setSrcLocFor loc (checkPat e [])
checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
-checkPatterns loc es = mapP (checkPattern loc) es
+checkPatterns loc es = mapM (checkPattern loc) es
checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
-checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
+checkPat (HsVar c) args | isRdrDataCon c = return (ConPatIn c (PrefixCon args))
checkPat (HsApp f x) args =
- checkPat x [] `thenP` \x ->
+ checkPat x [] >>= \x ->
checkPat f (x:args)
checkPat e [] = case e of
- EWildPat -> returnP (WildPat placeHolderType)
+ EWildPat -> return (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 ->
+ | 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 (NPatIn pos_lit Nothing)
+ NegApp (HsOverLit pos_lit) _ -> return (NPatIn pos_lit (Just placeHolderName))
+
+ ELazyPat e -> checkPat e [] >>= (return . LazyPat)
+ EAsPat n e -> checkPat e [] >>= (return . AsPat n)
+ ExprWithTySig e t -> checkPat 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
- HsForAllTy Nothing [] ty -> ty
+ HsForAllTy Implicit _ [] 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))
+ return (SigPatIn e t')
+ -- n+k patterns
OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
| plus == plus_RDR
- -> returnP (mkNPlusKPat n lit)
+ -> return (mkNPlusKPat n lit)
where
plus_RDR = mkUnqual varName FSLIT("+") -- Hack
- OpApp l op fix r -> checkPat l [] `thenP` \l ->
- checkPat r [] `thenP` \r ->
+ OpApp l op fix r -> checkPat l [] >>= \l ->
+ checkPat r [] >>= \r ->
case op of
HsVar c | isDataOcc (rdrNameOcc c)
- -> returnP (ConPatIn c (InfixCon l r))
+ -> return (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)
+ HsPar e -> checkPat e [] >>= (return . ParPat)
+ ExplicitList _ es -> mapM (\e -> checkPat e []) es >>= \ps ->
+ return (ListPat ps placeHolderType)
+ ExplicitPArr _ es -> mapM (\e -> checkPat e []) es >>= \ps ->
+ return (PArrPat ps placeHolderType)
- ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (TuplePat ps b)
+ ExplicitTuple es b -> mapM (\e -> checkPat e []) es >>= \ps ->
+ return (TuplePat ps b)
- RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
- returnP (ConPatIn c (RecCon fs))
+ RecordCon c fs -> mapM checkPatField fs >>= \fs ->
+ return (ConPatIn c (RecCon fs))
-- Generics
- HsType ty -> returnP (TypePat ty)
+ HsType ty -> return (TypePat ty)
_ -> patFail
checkPat _ _ = patFail
checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
-checkPatField (n,e) = checkPat e [] `thenP` \p ->
- returnP (n,p)
+checkPatField (n,e) = checkPat e [] >>= \p ->
+ return (n,p)
patFail = parseError "Parse error in pattern"
| 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))
+ -> checkPatterns loc es >>= \ps ->
+ return (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
Nothing ->
- checkPattern loc lhs `thenP` \lhs ->
- returnP (RdrValBinding (PatMonoBind lhs grhss loc))
+ checkPattern loc lhs >>= \lhs ->
+ return (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 (HsVar v) ty loc | isUnqual v = return (RdrHsDecl (SigD (Sig v ty loc)))
checkValSig other ty loc = parseError "Type signature given for an expression"
mkSigDecls :: [Sig RdrName] -> RdrBinding
-- Miscellaneous utilities
checkPrecP :: Int -> P Int
-checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i
+checkPrecP i | 0 <= i && i <= maxPrecedence = return i
| otherwise = parseError "Precedence out of range"
mkRecConstrOrUpdate
-> P RdrNameHsExpr
mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
- = returnP (RecordCon c fs)
+ = return (RecordCon c fs)
mkRecConstrOrUpdate exp fs@(_:_)
- = returnP (RecordUpd exp fs)
+ = return (RecordUpd exp fs)
mkRecConstrOrUpdate _ _
= parseError "Empty record update"
-> 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)
+ parseCImport entity cconv safety v >>= \importSpec ->
+ return $ ForD (ForeignImport v ty importSpec False loc)
mkImport (DNCall ) _ (entity, v, ty) loc =
- returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
+ parseDImport entity >>= \ spec ->
+ return $ 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 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?
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 :: 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] =
+ 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 "Malformed entity string"
+
-- construct a foreign export declaration
--
mkExport :: CallConv
-> (FastString, RdrName, RdrNameHsType)
-> SrcLoc
-> P RdrNameHsDecl
-mkExport (CCall cconv) (entity, v, ty) loc = returnP $
+mkExport (CCall cconv) (entity, v, ty) loc = return $
ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
where
entity' | nullFastString entity = mkExtName v
--
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}
parseError :: String -> P a
parseError s =
- getSrcLocP `thenP` \ loc ->
- failMsgP (hcat [ppr loc, text ": ", text s])
+ getSrcLoc >>= \ loc ->
+ failLocMsgP loc loc s
\end{code}
-
projects / ghc-hetmet.git / blobdiff