extractHsRhoRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl,
- mkHsNegApp, mkHsIntegral, mkHsFractional,
+ mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
cvBindGroup,
cvBindsAndSigs,
cvTopDecls,
- findSplice, mkGroup,
+ findSplice, checkDecBrGroup,
-- Stuff to do with Foreign declarations
CallConv(..),
#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 )
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
-----------------------------------------------------------------------------
findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
findSplice ds = addl emptyRdrGroup ds
-mkGroup :: [LHsDecl a] -> HsGroup a
-mkGroup ds = addImpDecls emptyRdrGroup 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"
+checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
+-- Turn the body of a [d| ... |] into a HsGroup
+-- There should be no splices in the "..."
+checkDecBrGroup decls
+ = case addl emptyRdrGroup decls of
+ (group, Nothing) -> return group
+ (_, Just (SpliceDecl (L loc _), _)) ->
+ parseError loc "Declaration splices are not permitted inside declaration brackets"
+ -- Why not? See Section 7.3 of the TH paper.
addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-- This stuff reverses the declarations (again) but it doesn't matter
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
- | isIdxTyDecl d =
- addl (gp { hs_tyclds = L l d : ts }) ds
+ addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) 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}
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 =
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"
ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
return (TuplePat ps b placeHolderType)
- RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
- return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
+ RecordCon c _ (HsRecordBinds fs) -> mapM checkPatField fs >>= \fs ->
+ return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
-- Generics
HsType ty -> return (TypePat ty)
_ -> patFail loc
-- 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
mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
= return (RecordCon (L l c) noPostTcExpr fs)
-mkRecConstrOrUpdate exp loc fs@(_:_)
- = return (RecordUpd exp fs placeHolderType placeHolderType)
-mkRecConstrOrUpdate _ loc []
+mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_))
+ = return (RecordUpd exp fs [] [] [])
+mkRecConstrOrUpdate _ loc (HsRecordBinds [])
= parseError loc "Empty record update"
mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec