%
-% (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 (
- RdrBinding(..),
-
- main_RDR_Unqual,
-
extractHsTyRdrTyVars,
extractHsRhoRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl,
mkHsNegApp, mkHsIntegral, mkHsFractional,
- mkHsDo, mkHsSplice, mkSigDecls,
+ mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
mkBootIface,
import HsSyn -- Lots of it
import IfaceType
-import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache )
-import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) )
+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(..))
+ DNCallSpec(..), DNKind(..), CLabelString )
import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
occNameUserString, isValOcc )
-import BasicTypes ( initialVersion )
-import TyCon ( DataConDetails(..) )
-import Module ( ModuleName )
+import BasicTypes ( initialVersion, StrictnessMark(..) )
+import Module ( Module )
import SrcLoc
-import CStrings ( CLabelString )
-import CmdLineOpts ( opt_InPackage )
+import OrdList ( OrdList, fromOL )
import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
import Outputable
import FastString
import List ( isSuffixOf, nubBy )
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Type synonyms}
-%* *
-%************************************************************************
-
-\begin{code}
-main_RDR_Unqual :: RdrName
-main_RDR_Unqual = mkUnqual varName FSLIT("main")
- -- We definitely don't want an Orig RdrName, because
- -- main might, in principle, be imported into module Main
-\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}
| 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 (unLoc p) 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)
extractGenericPatTyVars binds
= nubBy eqLocated (foldrBag get [] binds)
where
- get (L _ (FunBind _ _ ms)) acc = foldr (get_m.unLoc) acc ms
- get other acc = acc
+ get (L _ (FunBind _ _ (MatchGroup ms _))) acc = foldr (get_m.unLoc) acc ms
+ get other acc = acc
get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
get_m other acc = acc
= ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
tcdFDs = fds,
tcdSigs = sigs,
- tcdMeths = mbinds,
+ 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}
%* *
%************************************************************************
-mkBootIface, and its boring helper functions, have two purposes:
+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
becomes
This.foo :: GHC.Base.Int -> GHC.Base.Int
-It assumes that everything is well kinded, of course.
+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
+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 opt_InPackage mod) {
+ = (emptyModIface ThisPackage{-fill in later-} mod) {
mi_boot = True,
mi_exports = [(mod, map mk_export decls')],
mi_decls = decls_w_vers,
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),
ifVrcs = [] }
hsIfaceDecl (TyClD decl@(TyData {}))
- = IfaceData { ifND = tcdND decl,
- ifName = rdrNameOcc (tcdName decl),
- ifTyVars = hsIfaceTvs (tcdTyVars decl),
- ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
- ifCons = Unknown, ifRec = NonRecursive,
+ = 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
-
-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)
+ 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
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 (HsNumTy n) = panic "hsIfaceType:HsNum"
-hsIfaceType (HsPredTy p) = IfacePredTy (hsIfaceLPred p)
+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
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, IfaceLiftedTypeKind)
-hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k)
+hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind)
+hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)
-----------
hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
| (xs,ys) <- fds ]
\end{code}
-
-%************************************************************************
-%* *
-\subsection[rdrBinding]{Bindings straight out of the parser}
-%* *
-%************************************************************************
-
-\begin{code}
-data RdrBinding
- = -- Value bindings havn't been united with their
- -- signatures yet
- RdrBindings [RdrBinding] -- Convenience for parsing
-
- | RdrValBinding (LHsBind RdrName)
-
- -- The remainder all fit into the main HsDecl form
- | RdrHsDecl (LHsDecl RdrName)
-\end{code}
-
%************************************************************************
%* *
\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
\begin{code}
-cvTopDecls :: [RdrBinding] -> [LHsDecl RdrName]
--- Incoming bindings are in reverse order; result is in ordinary order
--- (a) flatten RdrBindings
--- (b) Group together bindings for a single function
-cvTopDecls decls
- = go [] decls
+-- | Groups together bindings for a single function
+cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
+cvTopDecls decls = go (fromOL decls)
where
- go :: [LHsDecl RdrName] -> [RdrBinding] -> [LHsDecl RdrName]
- go acc [] = acc
- go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2
- go acc (RdrHsDecl d : ds) = go (d : acc) ds
- go acc (RdrValBinding b : ds) = go (L l (ValD b') : acc) ds'
- where
- (L l b', ds') = getMonoBind b ds
-
-cvBindGroup :: [RdrBinding] -> HsBindGroup RdrName
+ 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
}
-cvBindsAndSigs :: [RdrBinding] -> (Bag (LHsBind RdrName), [LSig RdrName])
--- Input bindings are in *reverse* order,
--- and contain just value bindings and signatures
-cvBindsAndSigs fb
- = go (emptyBag, []) fb
+cvBindsAndSigs :: OrdList (LHsDecl RdrName)
+ -> (Bag (LHsBind RdrName), [LSig RdrName])
+-- Input decls contain just value bindings and signatures
+cvBindsAndSigs fb = go (fromOL fb)
where
- go acc [] = acc
- go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2
- go (bs, ss) (RdrHsDecl (L l (SigD s)) : ds) = go (bs, L l s : ss) ds
- go (bs, ss) (RdrValBinding b : ds) = go (b' `consBag` bs, ss) ds'
- where
- (b',ds') = getMonoBind b ds
+ go [] = (emptyBag, [])
+ go (L l (SigD s) : ds) = (bs, L l s : ss)
+ where (bs,ss) = go ds
+ go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
+ where (b',ds') = getMonoBind (L l b) ds
+ (bs,ss) = go ds'
-----------------------------------------------------------------------------
-- Group function bindings into equation groups
-getMonoBind :: LHsBind RdrName -> [RdrBinding] -> (LHsBind RdrName, [RdrBinding])
+getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
+ -> (LHsBind RdrName, [LHsDecl RdrName])
-- Suppose (b',ds') = getMonoBind b ds
-- ds is a *reversed* list of parsed bindings
-- b is a MonoBinds that has just been read off the front
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
-getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
+-- gaw 2004
+getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds
| has_args mtchs
= go mtchs loc binds
where
- go mtchs1 loc1 (RdrValBinding (L loc2 (FunBind f2 inf2 mtchs2)) : binds)
- | f == unLoc f2 = go (mtchs2 ++ mtchs1) loc binds
- -- Remember binds is reversed, so glue mtchs2 on the front
- -- and use loc2 as the final location
+ 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 mtchs1), binds)
+ 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)
-- 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
mkPrefixCon ty tys
= split ty tys
where
- split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
+ 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"
-- 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 (L _ (HsIParam n ty))) )
+checkPred (L spn (HsPredTy (HsIParam n ty)))
= return (L spn (HsIParam n ty))
checkPred (L spn ty)
= check spn ty []
checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
checkDictTy (L spn ty) = check ty []
where
- check (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
- = return (L spn (HsPredTy (L spn (HsClassP t args))))
+ 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"
HsType ty -> return (TypePat ty)
_ -> patFail loc
-checkAPat loc _ = patFail loc
-
checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
checkPatField (n,e) = do
p <- checkLPat e
checkValDef
:: LHsExpr RdrName
-> Maybe (LHsType RdrName)
- -> GRHSs RdrName
+ -> Located (GRHSs RdrName)
-> P (HsBind RdrName)
-checkValDef lhs opt_sig grhss
+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
- return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)])
- -- TODO: span is wrong
+ 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)
+ return (PatBind lhs grhss placeHolderType)
checkValSig
:: LHsExpr RdrName
checkValSig (L l other) ty
= parseError l "Type signature given for an expression"
-mkSigDecls :: [LSig RdrName] -> RdrBinding
-mkSigDecls sigs = RdrBindings [RdrHsDecl (L l (SigD sig)) | L l sig <- sigs]
-
-
-- A variable binding is parsed as a FunBind.
isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
projects / ghc-hetmet.git / blobdiff