%
-% (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,
- RdrNameGRHS,
- RdrNameGRHSs,
- RdrNameHsBinds,
- RdrNameHsDecl,
- RdrNameHsExpr,
- RdrNameHsModule,
- RdrNameIE,
- RdrNameImportDecl,
- RdrNameInstDecl,
- RdrNameMatch,
- RdrNameMonoBinds,
- RdrNamePat,
- RdrNameHsType,
- RdrNameHsTyVar,
- RdrNameSig,
- RdrNameStmt,
- RdrNameTyClDecl,
- RdrNameRuleDecl,
- RdrNameRuleBndr,
- RdrNameDeprecation,
- RdrNameHsRecordBinds,
- RdrNameFixitySig,
-
- RdrBinding(..),
- RdrMatch(..),
- SigConverter,
-
- extractHsTyRdrNames,
- extractHsTyRdrTyVars, extractHsTysRdrTyVars,
- extractPatsTyVars,
- extractRuleBndrsTyVars,
- extractHsCtxtRdrTyVars, extractGenericPatTyVars,
+ extractHsTyRdrTyVars,
+ extractHsRhoRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
- mkHsNegApp,
-
- cvBinds,
- cvMonoBindsAndSigs,
+ mkHsOpApp, mkClassDecl,
+ mkHsNegApp, mkHsIntegral, mkHsFractional,
+ mkHsDo, mkHsSplice,
+ mkTyData, mkPrefixCon, mkRecCon,
+ mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
+ mkBootIface,
+
+ cvBindGroup,
+ cvBindsAndSigs,
cvTopDecls,
- cvValSig, cvClassOpSig, cvInstDeclSig,
- mkTyData
+ 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 -- Lots of it
-import HsPat ( collectSigTysFromPats )
-import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
- mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
- mkGenOcc2,
- )
-import PrelNames ( negate_RDR )
-import RdrName ( RdrName, isRdrTyVar, mkRdrIfaceUnqual, rdrNameOcc,
- )
-import List ( nub )
-import BasicTypes ( RecFlag(..) )
-import Class ( DefMeth (..) )
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Type synonyms}
-%* *
-%************************************************************************
-
-\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 = HsContext RdrName
-type RdrNameHsDecl = HsDecl RdrName RdrNamePat
-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 = HsTyVarBndr 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 RdrNameDeprecation = DeprecDecl RdrName
-type RdrNameFixitySig = FixitySig RdrName
-
-type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
+import IfaceType
+import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache )
+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 ( ModuleName )
+import SrcLoc
+import CmdLineOpts ( opt_InPackage )
+import OrdList ( OrdList, fromOL )
+import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
+import Outputable
+import FastString
+import Panic
+
+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 :: 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 (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys
-extract_pred (HsPIParam 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 (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 (HsUsgTy usg ty) acc = extract_ty ty acc
-extract_ty (HsUsgForAllTy uv ty) acc = extract_ty ty acc
-extract_ty (HsTyVar tv) acc = tv : acc
-extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
--- Generics
-extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (HsNumTy num) acc = acc
--- Generics
-extract_ty (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 (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 = hsTyVarNames tvs
-
-
-extractPatsTyVars :: [RdrNamePat] -> [RdrName]
-extractPatsTyVars = filter isRdrTyVar .
- nub .
- extract_tys .
- collectSigTysFromPats
+ locals = hsLTyVarNames tvs
-extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
+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 _ _ ms)) acc = foldr (get_m.unLoc) acc ms
+ get other acc = acc
- get_m (Match _ (TypePatIn 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}
file (which would be equally good).
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 cxt cname tyvars fds sigs mbinds new_names loc
- where
- cls_occ = rdrNameOcc cname
- data_occ = mkClassDataConOcc cls_occ
- dname = mkRdrIfaceUnqual data_occ
- dwname = mkRdrIfaceUnqual (mkWorkerOcc data_occ)
- tname = mkRdrIfaceUnqual (mkClassTyConOcc cls_occ)
- sc_sel_names = [ mkRdrIfaceUnqual (mkSuperDictSelOcc n cls_occ)
- | n <- [1..length cxt]]
- -- We number off the superclass selectors, 1, 2, 3 etc so that we
- -- can construct names for the selectors. Thus
- -- class (C a, C b) => D a b where ...
- -- gives superclass selectors
- -- D_sc1, D_sc2
- -- (We used to call them D_C, but now we can have two different
- -- superclasses both called C!)
- new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
-
--- mkTyData :: ??
-mkTyData new_or_data context tname list_var list_con i maybe src
- = let t_occ = rdrNameOcc tname
- name1 = mkRdrIfaceUnqual (mkGenOcc1 t_occ)
- name2 = mkRdrIfaceUnqual (mkGenOcc2 t_occ)
- in TyData new_or_data context
- tname list_var list_con i maybe src name1 name2
-
-mkClassOpSig (DefMeth x) op ty loc
- = ClassOpSig op (Just (DefMeth dm_rn)) ty loc
- where
- dm_rn = mkRdrIfaceUnqual (mkDefaultMethodOcc (rdrNameOcc op))
-mkClassOpSig x op ty loc =
- ClassOpSig op (Just x) ty loc
-
-mkConDecl cname ex_vars cxt details loc
- = ConDecl cname wkr_name ex_vars cxt details loc
- where
- wkr_name = mkRdrIfaceUnqual (mkWorkerOcc (rdrNameOcc cname))
+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) data_cons maybe
+ = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
+ tcdTyVars = tyvars, tcdCons = data_cons,
+ tcdDerivs = maybe }
\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!
---
--- We also do the same service for boxed literals, because this function
--- is also used for patterns (which, remember, are parsed as expressions)
--- and pattern don't have negation in them.
---
--- Finally, it's important to represent minBound as minBound, and not
--- as (negate (-minBound)), becuase the latter is out of range.
-
-mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
-mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
-mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
-
-mkHsNegApp (HsOverLit (HsIntegral i n)) = HsOverLit (HsIntegral (-i) n)
-mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
-mkHsNegApp expr = NegApp expr negate_RDR
-\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
+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}
+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}
-data RdrMatch
- = RdrMatch
- [RdrNamePat]
- (Maybe RdrNameHsType)
- RdrNameGRHSs
+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 (unLoc name),
+ ifType = hsIfaceLType ty,
+ ifIdInfo = NoInfo }
+
+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 = hsIfaceTvs (tcdTyVars decl),
+ ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
+ ifCons = hsIfaceCons (tcdND decl) (tcdCons decl),
+ ifRec = NonRecursive,
+ ifVrcs = [], ifGeneric = False }
+ -- I'm not sure that [] is right for ifVrcs, but
+ -- since we don't use them I'm not going to fiddle
+
+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 decl = pprPanic "hsIfaceDecl" (ppr decl)
+
+hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls
+hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified",
+ = IfAbstractTyCon -- not "no constructors"
+
+hsIfaceCons DataType cons -- data type
+ = IfDataTyCon (map (hsIfaceCon . unLoc) cons)
+
+hsIfaceCons NewType [con] -- newtype
+ = IfNewTyCon (hsIfaceCon (unLoc con))
+
+
+hsIfaceCon :: ConDecl RdrName -> IfaceConDecl
+hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details)
+ = IfaceConDecl (get_occ lname) is_infix
+ (hsIfaceTvs ex_tvs)
+ (hsIfaceCtxt (unLoc ex_ctxt))
+ (map (hsIfaceLType . getBangType . unLoc) args)
+ (map (hsStrictMark . getBangStrictness . unLoc) args)
+ flds
+ where
+ (is_infix, args, flds) = case details of
+ PrefixCon args -> (False, args, [])
+ InfixCon a1 a2 -> (True, [a1,a2], [])
+ RecCon fs -> (False, map snd fs, map (get_occ . fst) fs)
+ get_occ lname = rdrNameOcc (unLoc lname)
+
+hsStrictMark :: HsBang -> StrictnessMark
+-- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
+-- but in an hi-boot file it's interpreted as the Truth!
+hsStrictMark HsNoBang = NotMarkedStrict
+hsStrictMark HsStrict = MarkedStrict
+hsStrictMark HsUnbox = MarkedUnboxed
+
+hsIfaceName rdr_name -- Qualify unqualifed occurrences
+ -- with the module name
+ | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
+ | 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 (HsPredTy p) = IfacePredTy (hsIfacePred p)
+hsIfaceType (HsKindSig t _) = hsIfaceLType t
+hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
+hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy"
+
+-----------
+hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
+
+-----------
+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 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[cvDecls]{Convert various top-level declarations}
+\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
%* *
%************************************************************************
-We make a point not to throw any user-pragma ``sigs'' at
-these conversion functions:
-
-\begin{code}
-cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
+Function definitions are restructured here. Each is assumed to be recursive
+initially, and non recursive definitions are discovered by the dependency
+analyser.
-cvValSig sig = sig
-cvInstDeclSig sig = sig
+\begin{code}
+-- | Groups together bindings for a single function
+cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
+cvTopDecls decls = go (fromOL decls)
+ where
+ 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
+ }
-cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
-cvClassOpSig sig = sig
+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
+
+getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
+ | has_args mtchs
+ = go mtchs loc binds
+ where
+ go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds)
+ | f == unLoc f2 = go (mtchs2++mtchs1) loc binds
+ where loc = combineSrcSpans loc1 loc2
+ go mtchs1 loc binds
+ = (L loc (FunBind lf inf (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}
%************************************************************************
%* *
-\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
+\subsection[PrefixToHS-utils]{Utilities for conversion}
%* *
%************************************************************************
-Function definitions are restructured here. Each is assumed to be recursive
-initially, and non recursive definitions are discovered by the dependency
-analyser.
\begin{code}
-cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
- -- The mysterious SigConverter converts Sigs to ClassOpSigs
- -- in class declarations. Mostly it's just an identity function
-
-cvBinds sig_cvtr binding
- = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
- MonoBind mbs sigs Recursive
- }
-\end{code}
-
-\begin{code}
-cvMonoBindsAndSigs :: SigConverter
- -> RdrBinding
- -> (RdrNameMonoBinds, [RdrNameSig])
-
-cvMonoBindsAndSigs sig_cvtr fb
- = mangle_bind (EmptyMonoBinds, []) fb
+-----------------------------------------------------------------------------
+-- 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 (unbangedType 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
- mangle_bind acc RdrNullBind
- = acc
+ -- 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"
- mangle_bind acc (RdrAndBindings fb1 fb2)
- = mangle_bind (mangle_bind acc fb1) fb2
+
+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
- mangle_bind (b_acc, s_acc) (RdrSig sig)
- = (b_acc, sig_cvtr sig : s_acc)
+ 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"
- mangle_bind (b_acc, s_acc) (RdrValBinding binding)
- = (b_acc `AndMonoBinds` binding, s_acc)
+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
+-- 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)
+ -> GRHSs RdrName
+ -> P (HsBind RdrName)
+
+checkValDef lhs opt_sig grhss
+ | Just (f,inf,es) <- isFunLhs lhs []
+ = if isQual (unLoc f)
+ then parseError (getLoc f) ("Qualified name in function definition: " ++
+ showRdrName (unLoc f))
+ else do ps <- checkPatterns es
+ return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)])
+ -- TODO: span is wrong
+ | otherwise = do
+ lhs <- checkPattern lhs
+ return (PatBind lhs grhss)
+
+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}
-%************************************************************************
-%* *
-\subsection[PrefixToHS-utils]{Utilities for conversion}
-%* *
-%************************************************************************
-
-Separate declarations into all the various kinds:
+-----------------------------------------------------------------------------
+-- Misc utils
\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)
- 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)
+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