Functions over HsSyn specialised to RdrName.
\begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module RdrHsSyn (
extractHsTyRdrTyVars,
extractHsRhoRdrTyVars, extractGenericPatTyVars,
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPred, -- HsType -> P HsPred
- checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
+ checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName
+ -- -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
checkTyVars, -- [LHsType RdrName] -> P ()
checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
checkKindSigs, -- [LTyClDecl RdrName] -> P ()
parseError, -- String -> Pa
) where
-#include "HsVersions.h"
-
import HsSyn -- Lots of it
import Class ( FunDep )
import TypeRep ( Kind )
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, isQual,
- setRdrNameSpace )
-import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
+ setRdrNameSpace, showRdrName )
+import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
+ InlinePragma(..), InlineSpec(..),
+ alwaysInlineSpec, neverInlineSpec )
import Lexer ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
DNCallSpec(..), DNKind(..), CLabelString )
import OccName ( srcDataName, varName, isDataOcc, isTcOcc,
occNameString )
+import PrelNames ( forall_tv_RDR )
import SrcLoc
import OrdList ( OrdList, fromOL )
import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
import List ( isSuffixOf, nubBy )
import Monad ( unless )
+
+#include "HsVersions.h"
\end{code}
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
= case cvBindsAndSigs binding of
- (mbs, sigs, [], _) -> -- list of type decls *always* empty
- ValBindsIn mbs sigs
+ (mbs, sigs, tydecls, _) -> ASSERT( null tydecls )
+ ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
where
go [] = (emptyBag, [], [], [])
go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
- where (bs, ss, ts, docs) = go ds
+ where (bs, ss, ts, docs) = go ds
go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
- where (b', ds') = getMonoBind (L l b) ds
- (bs, ss, ts, docs) = go ds'
+ 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 l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
- where (bs, ss, ts, docs) = go ds
+ where (bs, ss, ts, docs) = go ds
+ go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
+ where (bs, ss, ts, docs) = go ds
+ go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d)
-----------------------------------------------------------------------------
-- Group function bindings into equation groups
getMonoBind bind binds = (bind, binds)
has_args :: [LMatch RdrName] -> Bool
+has_args [] = panic "RdrHsSyn:has_args"
has_args ((L _ (Match args _ _)) : _) = not (null args)
-- Don't group together FunBinds if they have
-- no arguments. This is necessary now that variable bindings
= addl (gp { hs_defds = L l d : ts }) 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_warnds = ts}) l (WarningD d) ds
+ = addl (gp { hs_warnds = L l d : ts }) ds
+add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
+ = addl (gp { hs_annds = 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_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
+add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
add_sig :: LSig a -> HsValBinds a -> HsValBinds a
-add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
+add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
+add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
\end{code}
%************************************************************************
| isTcOcc (rdrNameOcc tc)
= return (L loc (setRdrNameSpace tc srcDataName))
| otherwise
- = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
+ = parseErrorSDoc loc (msg $$ extra)
+ where
+ msg = text "Not a data constructor:" <+> quotes (ppr tc)
+ extra | tc == forall_tv_RDR
+ = text "Perhaps you intended to use -XExistentialQuantification"
+ | otherwise = empty
----------------------------------------------------------------------------
-- Various Syntactic Checks
extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
extractTyVars tvs = collects tvs []
where
- -- Collect all variables (1st arg serves as an accumulator)
+ -- Collect all variables (2nd arg serves as an accumulator)
+ collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
+ -> P [LHsTyVarBndr RdrName]
collect (L l (HsForAllTy _ _ _ _)) =
const $ parseError l "Forall type not allowed as type parameter"
collect (L l (HsTyVar tv))
collect (L _ (HsNumTy _ )) = return
collect (L l (HsPredTy _ )) =
const $ parseError l "Predicate not allowed as type parameter"
- collect (L l (HsKindSig (L _ (HsTyVar tv)) k))
- | isRdrTyVar tv =
- return . (L l (KindedTyVar tv k) :)
- | otherwise =
- const $ parseError l "Kind signature only allowed for type variables"
+ collect (L l (HsKindSig (L _ ty) k))
+ | HsTyVar tv <- ty, isRdrTyVar tv
+ = return . (L l (KindedTyVar tv k) :)
+ | otherwise
+ = const $ parseError l "Kind signature only allowed for type variables"
collect (L l (HsSpliceTy _ )) =
const $ parseError l "Splice not allowed as type parameter"
+ collect (L _ (HsDocTy t _ )) = collect t
-- Collect all variables of a list of types
collects [] = return
checkDoMDo pre nm _ ss = do
check ss
where
+ check [] = panic "RdrHsSyn:checkDoMDo"
check [L _ (ExprStmt e _ _)] = return ([], e)
check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
" construct must be an expression")
| bang == bang_RDR
-> do { bang_on <- extension bangPatEnabled
; if bang_on then checkLPat e >>= (return . BangPat)
- else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
+ else parseError loc "Illegal bang-pattern (use -XBangPatterns)" }
ELazyPat e -> checkLPat e >>= (return . LazyPat)
EAsPat n e -> checkLPat e >>= (return . AsPat n)
-- n+k patterns
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
- (L _ (HsOverLit lit@(HsIntegral _ _ _)))
+ (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| plus == plus_RDR
-> return (mkNPlusKPat (L nloc n) lit)
_ -> patFail loc
plus_RDR, bang_RDR :: RdrName
-plus_RDR = mkUnqual varName FSLIT("+") -- Hack
-bang_RDR = mkUnqual varName FSLIT("!") -- Hack
+plus_RDR = mkUnqual varName (fsLit "+") -- Hack
+bang_RDR = mkUnqual varName (fsLit "!") -- Hack
checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
-> P (HsBind RdrName)
checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
| isQual (unLoc fun)
- = parseError (getLoc fun) ("Qualified name in function definition: " ++
- showRdrName (unLoc fun))
+ = parseErrorSDoc (getLoc fun)
+ (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
| otherwise
= do ps <- checkPatterns pats
let match_span = combineSrcSpans lhs_loc rhs_span
mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
-mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
+mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
-- The Maybe is becuase the user can omit the activation spec (and usually does)
-mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
-mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
-mkInlineSpec (Just act) inl = Inline act inl
+mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info
+ -- INLINE
+mkInlineSpec Nothing match_info False = neverInlineSpec match_info
+ -- NOINLINE
+mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl
-----------------------------------------------------------------------------
-> P ForeignImport
parseCImport (L loc entity) cconv safety v
-- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
- | entity == FSLIT ("dynamic") =
+ | entity == fsLit "dynamic" =
return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
- | entity == FSLIT ("wrapper") =
+ | entity == fsLit "wrapper" =
return $ CImport cconv safety nilFS nilFS CWrapper
| otherwise = parse0 (unpackFS entity)
where
parse2 _ _ [] = d'oh
parse2 isStatic kind (('[':x):xs) =
case x of
+ [] -> d'oh
vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
_ -> d'oh
parse2 isStatic kind xs = parse3 isStatic kind "" xs
-- Misc utils
\begin{code}
-showRdrName :: RdrName -> String
-showRdrName r = showSDoc (ppr r)
-
parseError :: SrcSpan -> String -> P a
-parseError span s = failSpanMsgP span s
+parseError span s = parseErrorSDoc span (text s)
+
+parseErrorSDoc :: SrcSpan -> SDoc -> P a
+parseErrorSDoc span s = failSpanMsgP span s
\end{code}
projects / ghc-hetmet.git / blobdiff