%
-% (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,
- RdrNameSpecDataSig,
- RdrNameDefaultDecl,
- RdrNameForeignDecl,
- RdrNameGRHS,
- RdrNameGRHSs,
- RdrNameHsBinds,
- RdrNameHsDecl,
- RdrNameHsExpr,
- RdrNameHsModule,
- RdrNameIE,
- RdrNameImportDecl,
- RdrNameInstDecl,
- RdrNameMatch,
- RdrNameMonoBinds,
- RdrNamePat,
- RdrNameHsType,
- RdrNameHsTyVar,
- RdrNameSig,
- RdrNameStmt,
- RdrNameTyClDecl,
- RdrNameRuleDecl,
- RdrNameRuleBndr,
- RdrNameHsRecordBinds,
-
- RdrBinding(..),
- RdrMatch(..),
- SigConverter,
-
- RdrNameClassOpPragmas,
- RdrNameClassPragmas,
- RdrNameDataPragmas,
- RdrNameGenPragmas,
- RdrNameInstancePragmas,
- extractHsTyRdrNames,
- extractHsTyRdrTyVars, extractHsTysRdrTyVars,
- extractPatsTyVars,
- extractRuleBndrsTyVars,
+ extractHsTyRdrTyVars,
+ extractHsRhoRdrTyVars, extractGenericPatTyVars,
- mkOpApp, mkClassDecl, mkClassOpSig,
-
- cvBinds,
- cvMonoBindsAndSigs,
+ mkHsOpApp, mkClassDecl,
+ mkHsNegApp, mkHsIntegral, mkHsFractional,
+ mkHsDo, mkHsSplice,
+ mkTyData, mkPrefixCon, mkRecCon,
+ mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
+ mkBootIface,
+
+ cvBindGroup,
+ cvBindsAndSigs,
cvTopDecls,
- cvValSig, cvClassOpSig, cvInstDeclSig
+ findSplice, mkGroup,
+
+ -- Stuff to do with Foreign declarations
+ , CallConv(..)
+ , mkImport -- CallConv -> Safety
+ -- -> (FastString, RdrName, RdrNameHsType)
+ -- -> P RdrNameHsDecl
+ , mkExport -- CallConv
+ -- -> (FastString, RdrName, RdrNameHsType)
+ -- -> 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
+ , 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
-import Name ( mkClassTyConOcc, mkClassDataConOcc )
-import OccName ( mkClassTyConOcc, mkClassDataConOcc,
- mkSuperDictSelOcc, mkDefaultMethodOcc
- )
-import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
-import Util ( thenCmp )
-import HsPragmas
-import List ( nub )
-import BasicTypes ( RecFlag(..) )
+import HsSyn -- Lots of it
+import IfaceType
+import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache,
+ IfacePackage(..) )
+import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) )
+import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
+ isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
+ setRdrNameSpace, rdrNameModule )
+import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
+import Lexer ( P, failSpanMsgP )
+import Kind ( liftedTypeKind )
+import HscTypes ( GenAvailInfo(..) )
+import TysWiredIn ( unitTyCon )
+import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
+ DNCallSpec(..), DNKind(..), CLabelString )
+import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
+ occNameUserString, isValOcc )
+import BasicTypes ( initialVersion, StrictnessMark(..) )
+import Module ( Module )
+import SrcLoc
+import OrdList ( OrdList, fromOL )
+import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
import Outputable
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Type synonyms}
-%* *
-%************************************************************************
+import FastString
+import Panic
-\begin{code}
-type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
-type RdrNameBangType = BangType RdrName
-type RdrNameClassOpSig = Sig RdrName
-type RdrNameConDecl = ConDecl RdrName
-type RdrNameConDetails = ConDetails RdrName
-type RdrNameContext = Context RdrName
-type RdrNameHsDecl = HsDecl RdrName RdrNamePat
-type RdrNameSpecDataSig = SpecDataSig 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 RdrNameIE = IE RdrName
-type RdrNameImportDecl = ImportDecl RdrName
-type RdrNameInstDecl = InstDecl RdrName RdrNamePat
-type RdrNameMatch = Match RdrName RdrNamePat
-type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
-type RdrNamePat = InPat RdrName
-type RdrNameHsType = HsType RdrName
-type RdrNameHsTyVar = HsTyVar RdrName
-type RdrNameSig = Sig RdrName
-type RdrNameStmt = Stmt RdrName RdrNamePat
-type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
-type RdrNameRuleBndr = RuleBndr RdrName
-type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
-
-type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
-
-type RdrNameClassOpPragmas = ClassOpPragmas RdrName
-type RdrNameClassPragmas = ClassPragmas RdrName
-type RdrNameDataPragmas = DataPragmas RdrName
-type RdrNameGenPragmas = GenPragmas RdrName
-type RdrNameInstancePragmas = InstancePragmas RdrName
+import List ( isSuffixOf, nubBy )
\end{code}
%* *
%************************************************************************
-@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 :: HsType RdrName -> [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
-
-extractHsCtxtRdrNames :: Context RdrName -> [RdrName]
-extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
-
-extract_ctxt ctxt acc = foldr extract_ass acc ctxt
- where
- extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
-
-extract_tys tys acc = foldr extract_ty acc tys
-
-extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoListTy ty) acc = extract_ty ty acc
-extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys
-extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys
-extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
-extract_ty (MonoUsgForAllTy uv ty) acc = extract_ty ty acc
-extract_ty (MonoTyVar tv) acc = tv : acc
-extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
-extract_ty (HsForAllTy (Just tvs) ctxt ty)
- acc = acc ++
- (filter (`notElem` locals) $
- extract_ctxt ctxt (extract_ty ty []))
+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 (HsTyVar tv)) acc
+ | isRdrTyVar tv = L loc tv : acc
+ | otherwise = acc
+extract_lty ty acc = extract_ty (unLoc ty) acc
+
+extract_ty (HsBangTy _ ty) acc = extract_lty ty acc
+extract_ty (HsAppTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
+extract_ty (HsListTy ty) acc = extract_lty ty acc
+extract_ty (HsPArrTy ty) acc = extract_lty ty acc
+extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys
+extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
+extract_ty (HsPredTy p) acc = extract_pred p acc
+extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
+extract_ty (HsParTy ty) acc = extract_lty ty acc
+extract_ty (HsNumTy num) acc = acc
+extract_ty (HsSpliceTy _) acc = acc -- Type splices mention no type variables
+extract_ty (HsKindSig ty k) acc = extract_lty ty acc
+extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
+extract_ty (HsForAllTy exp tvs cx ty)
+ acc = (filter ((`notElem` locals) . unLoc) $
+ extract_lctxt cx (extract_lty ty [])) ++ acc
where
- locals = map getTyVarName tvs
-
-
-extractPatsTyVars :: [RdrNamePat] -> [RdrName]
-extractPatsTyVars pats = filter isRdrTyVar (nub (foldr extract_pat [] pats))
-
-extract_pat (SigPatIn pat ty) acc = extract_ty ty acc
-extract_pat WildPatIn acc = acc
-extract_pat (VarPatIn var) acc = acc
-extract_pat (LitPatIn _) acc = acc
-extract_pat (LazyPatIn pat) acc = extract_pat pat acc
-extract_pat (AsPatIn a pat) acc = extract_pat pat acc
-extract_pat (NPlusKPatIn n _) acc = acc
-extract_pat (ConPatIn c pats) acc = foldr extract_pat acc pats
-extract_pat (ConOpPatIn p1 c f p2) acc = extract_pat p1 (extract_pat p2 acc)
-extract_pat (NegPatIn pat) acc = extract_pat pat acc
-extract_pat (ParPatIn pat) acc = extract_pat pat acc
-extract_pat (ListPatIn pats) acc = foldr extract_pat acc pats
-extract_pat (TuplePatIn pats _) acc = foldr extract_pat acc pats
-extract_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields
+ locals = hsLTyVarNames tvs
+
+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
+ = nubBy eqLocated (foldrBag get [] binds)
+ where
+ get (L _ (FunBind _ _ (MatchGroup ms _))) acc = foldr (get_m.unLoc) acc ms
+ get other acc = acc
+
+ get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
+ get_m other acc = acc
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Construction functions for Rdr stuff}
+%* *
+%************************************************************************
+
mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
by deriving them from the name of the class. We fill in the names for the
tycon and datacon corresponding to the class, by deriving them from the
name of the class itself. This saves recording the names in the interface
file (which would be equally good).
-Similarly for mkClassOpSig and default-method names.
+Similarly for mkConDecl, mkClassOpSig and default-method names.
+
+ *** See "THE NAMING STORY" in HsDecls ****
\begin{code}
-mkClassDecl cxt cname tyvars sigs mbinds prags loc
- = ClassDecl cxt cname tyvars sigs mbinds prags tname dname sc_sel_names loc
- where
- cls_occ = rdrNameOcc cname
- dname = mkRdrUnqual (mkClassDataConOcc cls_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!)
-
-mkClassOpSig has_default_method op ty loc
- = ClassOpSig op dm_rn has_default_method ty loc
- where
- dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
+mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
+ = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
+ tcdFDs = fds,
+ tcdSigs = sigs,
+ tcdMeths = mbinds
+ }
+
+mkTyData new_or_data (L _ (context, tname, tyvars)) ksig data_cons maybe_deriv
+ = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
+ tcdTyVars = tyvars, tcdCons = data_cons,
+ tcdKindSig = ksig, tcdDerivs = maybe_deriv }
\end{code}
-A useful function for building @OpApps@. The operator is always a variable,
-and we don't know the fixity yet.
-
\begin{code}
-mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
+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 (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) placeHolderName
\end{code}
%************************************************************************
%* *
-\subsection[rdrBinding]{Bindings straight out of the parser}
+ Hi-boot files
%* *
%************************************************************************
-\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
- -- signatures yet
- | RdrValBinding RdrNameMonoBinds
-
- -- Signatures are mysterious; we can't
- -- tell if its a Sig or a ClassOpSig,
- -- so we just save the pieces:
- | RdrSig RdrNameSig
-
- -- The remainder all fit into the main HsDecl form
- | RdrHsDecl RdrNameHsDecl
-
-type SigConverter = RdrNameSig -> RdrNameSig
-\end{code}
-
-\begin{code}
-data RdrMatch
- = RdrMatch
- [RdrNamePat]
- (Maybe RdrNameHsType)
- RdrNameGRHSs
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[cvDecls]{Convert various top-level declarations}
-%* *
-%************************************************************************
+mkBootIface, and its deeply boring helper functions, have two purposes:
-We make a point not to throw any user-pragma ``sigs'' at
-these conversion functions:
+a) HsSyn to IfaceSyn. The parser parses the former, but we're reading
+ an hi-boot file, and interfaces consist of the latter
-\begin{code}
-cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
+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
-cvValSig sig = sig
+It assumes that everything is well kinded, of course. Failure causes a
+fatal error using pgmError, rather than a monadic error. You're supposed
+to get hi-boot files right!
-cvInstDeclSig sig = sig
-cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var (panic "cvClassOpSig:dm_name")
- (panic "cvClassOpSig:dm_present")
- poly_ty src_loc
-cvClassOpSig sig = sig
+\begin{code}
+mkBootIface :: Module -> [HsDecl RdrName] -> ModIface
+-- Make the ModIface for a hi-boot file
+-- The decls are of very limited form
+-- The package will be filled in later (see LoadIface.readIface)
+mkBootIface mod decls
+ = (emptyModIface ThisPackage{-fill in later-} 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 (unLoc name),
+ ifType = hsIfaceLType ty,
+ ifIdInfo = NoInfo }
+
+hsIfaceDecl (TyClD decl@(ClassDecl {}))
+ = IfaceClass { ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
+ ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
+ ifSigs = [], -- Is this right??
+ ifRec = NonRecursive, ifVrcs = [] }
+
+hsIfaceDecl (TyClD decl@(TySynonym {}))
+ = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = hsIfaceTvs (tcdTyVars decl),
+ ifSynRhs = hsIfaceLType (tcdSynRhs decl),
+ ifVrcs = [] }
+
+hsIfaceDecl (TyClD decl@(TyData {}))
+ = IfaceData { ifName = rdrNameOcc (tcdName decl),
+ ifTyVars = tvs,
+ ifCons = hsIfaceCons tvs decl,
+ ifRec = Recursive, -- Hi-boot decls are always loop-breakers
+ ifVrcs = [], ifGeneric = False }
+ -- I'm not sure that [] is right for ifVrcs, but
+ -- since we don't use them I'm not going to fiddle
+ where
+ tvs = hsIfaceTvs (tcdTyVars decl)
+
+hsIfaceDecl decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
+
+hsIfaceCons :: [IfaceTvBndr] -> TyClDecl RdrName -> IfaceConDecls
+hsIfaceCons tvs decl@(TyData {tcdCtxt = L _ stupid_ctxt})
+ | not (null stupid_ctxt) -- Keep it simple: no data type contexts
+ -- Else we'll have to do "thinning"; sigh
+ = pprPgmError "Can't do data type contexts in hi-boot file:" (ppr decl)
+
+hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = []})
+ = -- data T a, meaning "constructors unspecified",
+ IfAbstractTyCon -- not "no constructors"
+
+hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = cons})
+ = IfDataTyCon Nothing (map (hsIfaceCon tvs . unLoc) cons)
+
+hsIfaceCons tvs (TyData {tcdND = NewType, tcdCons = [con]})
+ = IfNewTyCon (hsIfaceCon tvs (unLoc con))
+
+hsIfaceCons tvs decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
+
+
+hsIfaceCon :: [IfaceTvBndr] -> ConDecl RdrName -> IfaceConDecl
+hsIfaceCon tvs (ConDecl lname ex_tvs ex_ctxt details)
+ | null ex_tvs && null (unLoc ex_ctxt)
+ = IfVanillaCon { ifConOcc = get_occ lname,
+ ifConInfix = is_infix,
+ ifConArgTys = map hsIfaceLType args,
+ ifConStricts = map (hsStrictMark . getBangStrictness) args,
+ ifConFields = flds }
+ | null flds
+ = IfGadtCon { ifConOcc = get_occ lname,
+ ifConTyVars = tvs ++ hsIfaceTvs ex_tvs,
+ ifConCtxt = hsIfaceCtxt (unLoc ex_ctxt),
+ ifConArgTys = map hsIfaceLType args,
+ ifConResTys = map (IfaceTyVar . fst) tvs,
+ ifConStricts = map (hsStrictMark . getBangStrictness) args }
+ | otherwise = pprPgmError "Fields illegal in existential" (ppr (unLoc lname))
+ where
+ (is_infix, args, flds) = case details of
+ PrefixCon args -> (False, args, [])
+ InfixCon a1 a2 -> (True, [a1,a2], [])
+ RecCon fs -> (False, map snd fs, map (get_occ . fst) fs)
+ get_occ lname = rdrNameOcc (unLoc lname)
+
+hsIfaceCon _tvs (GadtDecl lname con_ty) -- Not yet
+ = pprPgmError "Can't use GADTs in hi-boot files (yet)" (ppr (unLoc lname))
+
+hsStrictMark :: HsBang -> StrictnessMark
+-- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
+-- but in an hi-boot file it's interpreted as the Truth!
+hsStrictMark HsNoBang = NotMarkedStrict
+hsStrictMark HsStrict = MarkedStrict
+hsStrictMark HsUnbox = MarkedUnboxed
+
+hsIfaceName rdr_name -- Qualify unqualifed occurrences
+ -- with the module name
+ | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
+ | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+
+hsIfaceLType :: LHsType RdrName -> IfaceType
+hsIfaceLType = hsIfaceType . unLoc
+
+hsIfaceType :: HsType RdrName -> IfaceType
+hsIfaceType (HsForAllTy exp tvs cxt ty)
+ = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
+ where
+ rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
+ tau = hsIfaceLType ty
+ tvs' = case exp of
+ Explicit -> map unLoc tvs
+ Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
+
+hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
+hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
+hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
+hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t]
+hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
+hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
+hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
+hsIfaceType (HsParTy t) = hsIfaceLType t
+hsIfaceType (HsBangTy _ t) = hsIfaceLType t
+hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p)
+hsIfaceType (HsKindSig t _) = hsIfaceLType t
+hsIfaceType ty = pprPanic "hsIfaceType" (ppr ty)
+ -- HsNumTy, HsSpliceTy
+
+-----------
+hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
+
+-----------
+hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
+hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
+
+-----------
+hsIfaceLPred :: LHsPred RdrName -> IfacePredType
+hsIfaceLPred = hsIfacePred . unLoc
+
+hsIfacePred :: HsPred RdrName -> IfacePredType
+hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
+hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
+
+-----------
+hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
+hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType 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 :: [LHsTyVarBndr RdrName] -> [IfaceTvBndr]
+hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
+
+-----------
+hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind)
+hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)
+
+-----------
+hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
+hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
+ | (xs,ys) <- fds ]
\end{code}
-
%************************************************************************
%* *
-\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
+\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
%* *
%************************************************************************
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) ->
- MonoBind mbs sigs Recursive
- }
-\end{code}
\begin{code}
-cvMonoBindsAndSigs :: SigConverter
- -> RdrBinding
- -> (RdrNameMonoBinds, [RdrNameSig])
-
-cvMonoBindsAndSigs sig_cvtr fb
- = mangle_bind (EmptyMonoBinds, []) fb
+-- | Groups together bindings for a single function
+cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
+cvTopDecls decls = go (fromOL decls)
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)
+ go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
+ go [] = []
+ go (L l (ValD b) : ds) = L l' (ValD b') : go ds'
+ where (L l' b', ds') = getMonoBind (L l b) ds
+ go (d : ds) = d : go ds
+
+cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
+cvBindGroup binding
+ = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
+ HsBindGroup mbs sigs Recursive -- just one big group for now
+ }
- mangle_bind (b_acc, s_acc) (RdrValBinding binding)
- = (b_acc `AndMonoBinds` binding, s_acc)
+cvBindsAndSigs :: OrdList (LHsDecl RdrName)
+ -> (Bag (LHsBind RdrName), [LSig RdrName])
+-- Input decls contain just value bindings and signatures
+cvBindsAndSigs fb = go (fromOL fb)
+ where
+ go [] = (emptyBag, [])
+ go (L l (SigD s) : ds) = (bs, L l s : ss)
+ where (bs,ss) = go ds
+ go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
+ where (b',ds') = getMonoBind (L l b) ds
+ (bs,ss) = go ds'
+
+-----------------------------------------------------------------------------
+-- Group function bindings into equation groups
+
+getMonoBind :: LHsBind RdrName -> [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
+
+-- 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
+
+-- gaw 2004
+getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds
+ | has_args mtchs
+ = go mtchs loc binds
+ where
+ 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))), binds)
+ -- reverse the final matches, to get it back in the right order
+
+getMonoBind bind binds = (bind, binds)
+
+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 FunBinds rather
+ -- than pattern bindings (tests/rename/should_fail/rnfail002).
\end{code}
+\begin{code}
+emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
+ hs_tyclds = [], hs_instds = [],
+ hs_fixds = [], hs_defds = [], hs_fords = [],
+ hs_depds = [] ,hs_ruleds = [] }
+
+findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
+findSplice ds = addl emptyGroup ds
+
+mkGroup :: [LHsDecl a] -> HsGroup a
+mkGroup ds = addImpDecls emptyGroup ds
+
+addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
+-- The decls are imported, and should not have a splice
+addImpDecls group decls = case addl group decls of
+ (group', Nothing) -> group'
+ other -> panic "addImpDecls"
+
+addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
+ -- This stuff reverses the declarations (again) but it doesn't matter
+
+-- Base cases
+addl gp [] = (gp, Nothing)
+addl gp (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}) 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}) 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}) 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}) 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 [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r]
+add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r]
+\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
-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 :: LHsType RdrName -> [LBangType RdrName]
+ -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
+mkPrefixCon ty tys
+ = split ty tys
+ where
+ 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)
+ = return (L loc (setRdrNameSpace tc srcDataName))
+ | otherwise
+ = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
+
+----------------------------------------------------------------------------
+-- Various Syntactic Checks
+
+checkInstType :: LHsType RdrName -> P (LHsType RdrName)
+checkInstType (L l t)
+ = case t of
+ HsForAllTy exp tvs ctxt ty -> do
+ dict_ty <- checkDictTy ty
+ return (L l (HsForAllTy exp tvs ctxt dict_ty))
+
+ HsParTy ty -> checkInstType ty
+
+ ty -> do dict_ty <- checkDictTy (L l ty)
+ return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
+
+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"
+
+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 (L l cxt) ty
+ = do (tc, tvs) <- gol ty []
+ mapM_ chk_pred cxt
+ return (L l cxt, tc, tvs)
+ where
+ 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 (L spn (HsPredTy (HsIParam n ty)))
+ = return (L spn (HsIParam n ty))
+checkPred (L spn ty)
+ = check spn ty []
+ where
+ checkl (L l ty) args = check l ty args
+
+ 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 (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
- 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)
+ 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
+-- same comments apply for mdo as well
+
+checkDo = checkDoMDo "a " "'do'"
+checkMDo = checkDoMDo "an " "'mdo'"
+
+checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt 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 [L l (ResultStmt e)]
+ check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
+ " construct must be an expression")
+ check (s:ss) = do
+ ss' <- check 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 :: 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 (NPatIn pos_lit Nothing)
+ NegApp (L _ (HsOverLit pos_lit)) _
+ -> return (NPatIn pos_lit (Just placeHolderName))
+
+ 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 -> return (TypePat ty)
+ _ -> patFail loc
+
+checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
+checkPatField (n,e) = do
+ p <- checkLPat e
+ return (n,p)
+
+patFail loc = parseError loc "Parse error in pattern"
+
+
+---------------------------------------------------------------------------
+-- Check Equation Syntax
+
+checkValDef
+ :: 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
+ return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)]))
+ -- The span of the match covers the entire equation.
+ -- That isn't quite right, but it'll do for now.
+ | otherwise = do
+ lhs <- checkPattern lhs
+ return (PatBind lhs grhss placeHolderType)
+
+checkValSig
+ :: LHsExpr RdrName
+ -> LHsType RdrName
+ -> P (Sig RdrName)
+checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
+checkValSig (L l other) ty
+ = parseError l "Type signature given for an expression"
+
+-- 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 :: Located Int -> P Int
+checkPrecP (L l i)
+ | 0 <= i && i <= maxPrecedence = return i
+ | otherwise = parseError l "Precedence out of range"
+
+mkRecConstrOrUpdate
+ :: LHsExpr RdrName
+ -> SrcSpan
+ -> HsRecordBinds RdrName
+ -> P (HsExpr RdrName)
+
+mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
+ = return (RecordCon (L l c) fs)
+mkRecConstrOrUpdate exp loc fs@(_:_)
+ = return (RecordUpd exp fs)
+mkRecConstrOrUpdate _ loc []
+ = parseError loc "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
+ -> (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 :: Located FastString
+ -> CCallConv
+ -> Safety
+ -> Located RdrName
+ -> P ForeignImport
+parseCImport (L loc entity) cconv safety v
+ -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
+ | entity == FSLIT ("dynamic") =
+ return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
+ | entity == FSLIT ("wrapper") =
+ return $ 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 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 (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 loc "Malformed entity string"
+ where
+ (first, rest) = break (== ' ') str
+ --
+ build cid header False lib = return $
+ CImport cconv safety header lib (CFunction (StaticTarget cid))
+ 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
+ -> (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 (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))
+\end{code}
+
+
+-----------------------------------------------------------------------------
+-- Misc utils
+
+\begin{code}
+showRdrName :: RdrName -> String
+showRdrName r = showSDoc (ppr r)
+
+parseError :: SrcSpan -> String -> P a
+parseError span s = failSpanMsgP span s
\end{code}
projects / ghc-hetmet.git / blobdiff