mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
- mkBootIface,
cvBindGroup,
cvBindsAndSigs,
, checkPrecP -- Int -> P Int
, checkContext -- HsType -> P HsContext
, checkPred -- HsType -> P HsPred
- , checkTyClHdr -- HsType -> (name,[tyvar])
+ , checkTyClHdr
+ , checkSynHdr
, checkInstType -- HsType -> P HsType
, checkPattern -- HsExp -> P HsPat
, checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
#include "HsVersions.h"
import HsSyn -- Lots of it
-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 )
+ setRdrNameSpace )
+import BasicTypes ( RecFlag(..), maxPrecedence )
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 OccName ( srcDataName, varName, isDataOcc, isTcOcc,
+ occNameUserString )
import SrcLoc
-import CmdLineOpts ( opt_InPackage )
import OrdList ( OrdList, fromOL )
import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
import Outputable
extractHsRhoRdrTyVars ctxt ty
= nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
-extract_lctxt ctxt acc = foldr (extract_pred.unLoc) acc (unLoc ctxt)
+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 = hsLTyVarNames tvs
+extract_lty (L loc ty) acc
+ = case ty of
+ HsTyVar tv -> extract_tv loc tv acc
+ HsBangTy _ ty -> extract_lty ty acc
+ HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
+ HsListTy ty -> extract_lty ty acc
+ HsPArrTy ty -> extract_lty ty acc
+ HsTupleTy _ tys -> foldr extract_lty acc tys
+ HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
+ HsPredTy p -> extract_pred p acc
+ HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
+ HsParTy ty -> extract_lty ty acc
+ HsNumTy num -> acc
+ HsSpliceTy _ -> acc -- Type splices mention no type variables
+ HsKindSig ty k -> extract_lty ty acc
+ HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc)
+ HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
+ extract_lctxt cx (extract_lty ty []))
+ where
+ locals = hsLTyVarNames tvs
+
+extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
+extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
+ | otherwise = acc
extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
-- Get the type variables out of the type patterns in a bunch of
tcdMeths = mbinds
}
-mkTyData new_or_data (context, tname, tyvars) data_cons maybe
+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,
- tcdDerivs = maybe }
+ tcdKindSig = ksig, tcdDerivs = maybe_deriv }
\end{code}
\begin{code}
%************************************************************************
%* *
- Hi-boot files
-%* *
-%************************************************************************
-
-mkBootIface, and its deeply 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. Failure causes a
-fatal error using pgmError, rather than a monadic error. You're supposed
-to get hi-boot files right!
-
-
-\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 (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 = 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
- 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@, etc.}
%* *
%************************************************************************
-- This stuff reverses the declarations (again) but it doesn't matter
-- Base cases
-addl gp [] = (gp, Nothing)
+addl gp [] = (gp, Nothing)
addl gp (L l d : ds) = add gp l d ds
chk (L l other)
= parseError l "Type found where type variable expected"
+checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
+checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
+ ; return (tc, tvs) }
+
checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
-> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
-- The header of a type or class decl should look like
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"
+ check _loc (HsTyVar t) args | not (isRdrTyVar t)
+ = return (L spn (HsClassP t args))
+ check _loc (HsAppTy l r) args = checkl l (r:args)
+ check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
+ check _loc (HsParTy t) args = checkl t args
+ check loc _ _ = parseError loc "malformed class assertion"
checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
checkDictTy (L spn ty) = check ty []
projects / ghc-hetmet.git / blobdiff