findSplice, mkGroup,
-- Stuff to do with Foreign declarations
- , CallConv(..)
- , mkImport -- CallConv -> Safety
+ CallConv(..),
+ mkImport, -- CallConv -> Safety
-- -> (FastString, RdrName, RdrNameHsType)
-- -> P RdrNameHsDecl
- , mkExport -- CallConv
+ mkExport, -- CallConv
-- -> (FastString, RdrName, RdrNameHsType)
-- -> P RdrNameHsDecl
- , mkExtName -- RdrName -> CLabelString
+ 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
+ checkPrecP, -- Int -> P Int
+ checkContext, -- HsType -> P HsContext
+ checkPred, -- HsType -> P HsPred
+ checkTyClHdr,
+ checkSynHdr,
+ 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 IfaceType
-import Packages ( PackageIdH(..) )
-import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache,
- Dependencies(..), IsBootInterface, noDependencies )
-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 ( Module )
+import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
+ occNameUserString )
import SrcLoc
import OrdList ( OrdList, fromOL )
import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
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
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
+ f expr = NegApp (L loc e) noSyntaxExpr
\end{code}
%************************************************************************
\begin{code}
--- | Groups together bindings for a single function
+-- | Groups together bindings for a single function
cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
cvTopDecls decls = go (fromOL decls)
where
\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
+findSplice ds = addl oneEmptyBindGroup ds
mkGroup :: [LHsDecl a] -> HsGroup a
-mkGroup ds = addImpDecls emptyGroup ds
+mkGroup ds = addImpDecls oneEmptyBindGroup ds
+
+oneEmptyBindGroup = emptyGroup{ hs_valds = [HsBindGroup emptyBag [] Recursive] }
addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
-- The decls are imported, and should not have a splice
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 []
-- 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
+-- (b) returns it separately
-- 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 :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr 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 (ExprStmt e _ _)] = return ([], 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')
+ (ss',e') <- check ss
+ return ((s:ss'),e')
-- -------------------------------------------------------------------------
-- Checking Patterns.
-- 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)
+ HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
NegApp (L _ (HsOverLit pos_lit)) _
- -> return (NPatIn pos_lit (Just placeHolderName))
+ -> return (mkNPat pos_lit (Just noSyntaxExpr))
ELazyPat e -> checkLPat e >>= (return . LazyPat)
EAsPat n e -> checkLPat e >>= (return . AsPat n)
ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
return (TuplePat ps b)
- RecordCon c fs -> mapM checkPatField fs >>= \fs ->
+ RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
return (ConPatIn c (RecCon fs))
-- Generics
HsType ty -> return (TypePat ty)
-> P (HsExpr RdrName)
mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
- = return (RecordCon (L l c) fs)
+ = return (RecordCon (L l c) noPostTcExpr fs)
mkRecConstrOrUpdate exp loc fs@(_:_)
- = return (RecordUpd exp fs)
+ = return (RecordUpd exp fs placeHolderType placeHolderType)
mkRecConstrOrUpdate _ loc []
= parseError loc "Empty record update"