extractHsRhoRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl,
- mkHsNegApp, mkHsIntegral, mkHsFractional,
+ mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
checkInstType, -- HsType -> P HsType
checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
checkPattern, -- HsExp -> P HsPat
+ bang_RDR,
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
checkDo, -- [Stmt] -> P [Stmt]
checkMDo, -- [Stmt] -> P [Stmt]
#include "HsVersions.h"
import HsSyn -- Lots of it
-import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
+import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace )
import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
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_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
+extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
+extract_pred (HsIParam n ty ) acc = extract_lty ty acc
extract_lty (L loc ty) acc
= case ty of
ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
- -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity RdrName])
+ -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
-- Input decls contain just value bindings and signatures
-- and in case of class or instance declarations also
-- associated type declarations. They might also contain Haddock comments.
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = (emptyBag, [], [], [])
- go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs)
+ go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, docs)
where (bs, ss, ts, docs) = go ds
- go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, add_doc x docs)
+ go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
where (b', ds') = getMonoBind (L l b) ds
(bs, ss, ts, docs) = go ds'
go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
where (bs, ss, ts, docs) = go ds
- go (L _ (DocD d) : ds) = (bs, ss, ts, DocEntity d : docs)
+ go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
where (bs, ss, ts, docs) = go ds
-----------------------------------------------------------------------------
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, hs_docs = docs})
- l decl@(TyClD d) ds
+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,
- hs_docs = add_doc decl docs}) ds
+ addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
+ | isFamInstDecl d =
+ addl (gp { hs_tyclds = L l d : ts }) ds
| otherwise =
- addl (gp { hs_tyclds = L l d : ts,
- hs_docs = add_doc decl docs }) ds
+ 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, hs_docs = docs}) l x@(SigD d) ds
- = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) 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, hs_docs = docs}) l x@(ValD d) ds
- = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) ds
+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_derivds = 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, hs_docs = docs}) l x@(ForD d) ds
- = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) 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 gp l (DocD d) ds
- = addl (gp { hs_docs = DocEntity d : (hs_docs gp) }) ds
+ = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
-add_doc decl docs = case getMainDeclBinder decl of
- Just name -> DeclEntity name : docs
- Nothing -> docs
-
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
\end{code}
ty -> do dict_ty <- checkDictTy (L l ty)
return (L l (HsForAllTy Implicit [] (noLoc []) dict_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 (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 instance header"
+
-- Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature). If the second argument is `False',
-- only type variables are allowed and we raise an error on encountering a
where
gol (L l ty) acc = go l ty acc
- go l (HsTyVar tc) acc
- | not (isRdrTyVar tc) = do
- tvs <- extractTyVars acc
- return (L l tc, tvs, acc)
- go l (HsOpTy t1 tc t2) acc = do
- tvs <- extractTyVars (t1:t2:acc)
- return (tc, tvs, acc)
+ go l (HsTyVar tc) acc
+ | isRdrTc tc = do tvs <- extractTyVars acc
+ return (L l tc, tvs, acc)
+ go l (HsOpTy t1 ltc@(L _ tc) t2) acc
+ | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
+ return (ltc, tvs, acc)
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 head of type or 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 ()
+ -- The predicates in a type or class decl must be class predicates or
+ -- equational constraints. They need not all have variable-only
+ -- arguments, even in Haskell 98.
+ -- E.g. class (Monad m, Monad (t m)) => MonadT t m
+ chk_pred (L l (HsClassP _ _)) = return ()
+ chk_pred (L l (HsEqualP _ _)) = return ()
chk_pred (L l _)
= parseError l "Malformed context in type or class declaration"
checkKindSigs = mapM_ check
where
check (L l tydecl)
- | isKindSigDecl tydecl
+ | isFamilyDecl tydecl
|| isSynDecl tydecl = return ()
| otherwise =
parseError l "Type declaration in a class must be a kind signature or synonym default"
where
checkl (L l ty) args = check l ty args
+ check _loc (HsPredTy pred@(HsEqualP _ _))
+ args | null args
+ = return $ L spn pred
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 []
- 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"
-
+ check loc _ _ = parseError loc
+ "malformed class assertion"
---------------------------------------------------------------------------
-- Checking stand-alone deriving declarations
-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
makeFunBind fn is_infix ms
= FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
- fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames }
+ fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
checkPatBind lhs (L _ grhss)
= do { lhs <- checkPattern lhs
-- The parser left-associates, so there should
-- not be any OpApps inside the e's
splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
--- Splits (f ! g a b) into (f, [(! g), a, g])
+-- Splits (f ! g a b) into (f, [(! g), a, b])
splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
| op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
where
isFunLhs :: LHsExpr RdrName
-> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
-- Just (fun, is_infix, arg_pats) if e is a function LHS
+--
+-- The whole LHS is parsed as a single expression.
+-- Any infix operators on the LHS will parse left-associatively
+-- E.g. f !x y !z
+-- will parse (rather strangely) as
+-- (f ! x y) ! z
+-- It's up to isFunLhs to sort out the mess
+--
+-- a .!. !b
+
isFunLhs e = go e []
where
go (L loc (HsVar f)) es
projects / ghc-hetmet.git / blobdiff