extractHsRhoRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl,
- mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsIsString,
+ mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
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 )
-import Lexer ( P, failSpanMsgP, extension, glaExtsEnabled, bangPatEnabled )
+ 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 Outputable
import FastString
-import Panic
import List ( isSuffixOf, nubBy )
import Monad ( unless )
+
+#include "HsVersions.h"
\end{code}
extractHsRhoRdrTyVars ctxt ty
= nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
+extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
-extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
+extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
+extract_pred (HsClassP _ 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_pred (HsIParam _ ty ) acc = extract_lty ty acc
+extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
extract_lty (L loc ty) acc
= case ty of
HsTyVar tv -> extract_tv loc tv 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
+ HsNumTy _ -> 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) $
+ HsKindSig ty _ -> extract_lty ty acc
+ HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
+ HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
extract_lctxt cx (extract_lty ty []))
where
locals = hsLTyVarNames tvs
- HsDocTy ty doc -> extract_lty ty acc
+ HsDocTy ty _ -> extract_lty ty acc
extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
= nubBy eqLocated (foldrBag get [] binds)
where
get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
- get other acc = acc
+ get _ acc = acc
get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
- get_m other acc = acc
+ get_m _ acc = acc
\end{code}
*** See "THE NAMING STORY" in HsDecls ****
\begin{code}
+mkClassDecl :: (LHsContext name, Located name, [LHsTyVarBndr name])
+ -> [Located (FunDep name)]
+ -> [LSig name]
+ -> LHsBinds name
+ -> [LTyClDecl name]
+ -> [LDocDecl name]
+ -> TyClDecl name
mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
= ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
tcdFDs = fds,
tcdDocs = docs
}
+mkTyData :: NewOrData
+ -> (LHsContext name,
+ Located name,
+ [LHsTyVarBndr name],
+ Maybe [LHsType name])
+ -> Maybe Kind
+ -> [LConDecl name]
+ -> Maybe [LHsType name]
+ -> TyClDecl name
mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
= TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
tcdKindSig = ksig, tcdDerivs = maybe_deriv }
\end{code}
-\begin{code}
-mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
--- RdrName If the type checker sees (negate 3#) it will barf, because negate
--- can't take an unboxed arg. But that is exactly what it will see when
--- we write "-3#". So we have to do the negation right now!
-mkHsNegApp (L loc e) = f e
- 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) noSyntaxExpr
-\end{code}
-
%************************************************************************
%* *
\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
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])
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = (emptyBag, [], [], [])
- 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, docs)
- where (b', ds') = getMonoBind (L l b) ds
- (bs, ss, ts, docs) = go ds'
+ go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
+ 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'
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
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
-getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
- fun_matches = MatchGroup mtchs1 _ })) binds
+getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
+ fun_matches = MatchGroup mtchs1 _ })) binds
| has_args mtchs1
= go is_infix1 mtchs1 loc1 binds []
where
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
add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
-> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-add gp l (SpliceD e) ds = (gp, Just (e, ds))
+add gp _ (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})
= 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 gp l (DocD d) ds
= addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
+add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
-add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s: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 _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
\end{code}
%************************************************************************
-- arguments, and converts the type constructor back into a data constructor.
mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
- -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
+ -> P (Located RdrName, HsConDeclDetails RdrName)
mkPrefixCon ty tys
= split ty tys
where
mkRecCon :: Located RdrName ->
[([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
- P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
+ P (Located RdrName, HsConDeclDetails RdrName)
mkRecCon (L loc con) fields
= do data_con <- tyConToDataCon loc con
- return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
+ return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
| 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
checkTyVars tparms = mapM_ chk tparms
where
-- Check that the name space is correct!
- chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
+ chk (L _ (HsKindSig (L _ (HsTyVar tv)) _))
| isRdrTyVar tv = return ()
- chk (L l (HsTyVar tv))
+ chk (L _ (HsTyVar tv))
| isRdrTyVar tv = return ()
- chk (L l other) =
+ chk (L l _) =
parseError l "Type found where type variable expected"
-- Check whether the type arguments in a type synonym head are simply
--- variables. If not, we have a type equation of a type function and return
--- all patterns. If yes, we return 'Nothing' as the third component to
--- indicate a vanilla type synonym.
+-- variables. If not, we have a type family instance and return all patterns.
+-- If yes, we return 'Nothing' as the third component to indicate a vanilla
+-- type synonym.
--
checkSynHdr :: LHsType RdrName
-> Bool -- is type instance?
-- etc
-- With associated types, we can also have non-variable parameters; ie,
-- T Int [a]
+-- or Int :++: [a]
-- The unaltered parameter list is returned in the fourth component of the
-- result. Eg, for
-- T Int [a]
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
+ go _ (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 =
+ return (ltc, tvs, t1:t2:acc)
+ go _ (HsParTy ty) acc = gol ty acc
+ go _ (HsAppTy t1 t2) acc = gol t1 (t2:acc)
+ go l _ _ =
parseError l "Malformed head of type or class declaration"
-- 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 _ (HsClassP _ _)) = return ()
+ chk_pred (L _ (HsEqualP _ _)) = return ()
chk_pred (L l _)
= parseError l "Malformed context in type or class declaration"
-- declarations).
--
extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-extractTyVars tvs = collects [] tvs
+extractTyVars tvs = collects tvs []
where
- -- Collect all variables (1st arg serves as an accumulator)
- collect tvs (L l (HsForAllTy _ _ _ _)) =
- parseError l "Forall type not allowed as type parameter"
- collect tvs (L l (HsTyVar tv))
- | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
- | otherwise = return tvs
- collect tvs (L l (HsBangTy _ _ )) =
- parseError l "Bang-style type annotations not allowed as type parameter"
- collect tvs (L l (HsAppTy t1 t2 )) = do
- tvs' <- collect tvs t2
- collect tvs' t1
- collect tvs (L l (HsFunTy t1 t2 )) = do
- tvs' <- collect tvs t2
- collect tvs' t1
- collect tvs (L l (HsListTy t )) = collect tvs t
- collect tvs (L l (HsPArrTy t )) = collect tvs t
- collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
- collect tvs (L l (HsOpTy t1 _ t2 )) = do
- tvs' <- collect tvs t2
- collect tvs' t1
- collect tvs (L l (HsParTy t )) = collect tvs t
- collect tvs (L l (HsNumTy t )) = return tvs
- collect tvs (L l (HsPredTy t )) =
- parseError l "Predicate not allowed as type parameter"
- collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
- | isRdrTyVar tv =
- return $ L l (KindedTyVar tv k) : tvs
- | otherwise =
- parseError l "Kind signature only allowed for type variables"
- collect tvs (L l (HsSpliceTy t )) =
- parseError l "Splice not allowed as type parameter"
+ -- 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))
+ | isRdrTyVar tv = return . (L l (UserTyVar tv) :)
+ | otherwise = return
+ collect (L l (HsBangTy _ _ )) =
+ const $ parseError l "Bang-style type annotations not allowed as type parameter"
+ collect (L _ (HsAppTy t1 t2 )) = collect t2 >=> collect t1
+ collect (L _ (HsFunTy t1 t2 )) = collect t2 >=> collect t1
+ collect (L _ (HsListTy t )) = collect t
+ collect (L _ (HsPArrTy t )) = collect t
+ collect (L _ (HsTupleTy _ ts )) = collects ts
+ collect (L _ (HsOpTy t1 _ t2 )) = collect t2 >=> collect t1
+ collect (L _ (HsParTy t )) = collect t
+ collect (L _ (HsNumTy _ )) = return
+ collect (L l (HsPredTy _ )) =
+ const $ parseError l "Predicate not allowed as type parameter"
+ 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 tvs [] = return tvs
- collects tvs (t:ts) = do
- tvs' <- collects tvs ts
- collect tvs' t
+ collects [] = return
+ collects (t:ts) = collects ts >=> collect t
+
+ (f >=> g) x = f x >>= g
-- Check that associated type declarations of a class are all kind signatures.
--
checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
checkDerivDecl d@(L loc _) =
- do glaExtOn <- extension glaExtsEnabled
- if glaExtOn then return d
- else parseError loc "Illegal stand-alone deriving declaration (use -fglasgow-exts)"
+ do stDerivOn <- extension standaloneDerivingEnabled
+ if stDerivOn then return d
+ else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
---------------------------------------------------------------------------
-- Checking statements in a do-expression
-- (b) returns it separately
-- same comments apply for mdo as well
+checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
+
checkDo = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"
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
+checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
+checkDoMDo pre nm _ ss = do
check ss
where
- check [L l (ExprStmt e _ _)] = return ([], e)
+ 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")
check (s:ss) = do
= do { x <- checkLPat x; checkPat loc f (x:args) }
checkPat loc (L _ e) []
= do { p <- checkAPat loc e; return (L loc p) }
-checkPat loc pat _some_args
+checkPat loc _ _
= patFail loc
+checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
checkAPat loc e = case e of
EWildPat -> return (WildPat placeHolderType)
HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
-- Overloaded numeric patterns (e.g. f 0 x = x)
-- 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 (mkNPat pos_lit Nothing)
+ -- NB. Negative *primitive* literals are already handled by the lexer
+ HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
NegApp (L _ (HsOverLit pos_lit)) _
-> return (mkNPat pos_lit (Just noSyntaxExpr))
| 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)
- ExprWithTySig e t -> checkLPat e >>= \e ->
- -- Pattern signatures are parsed as sigtypes,
- -- but they aren't explicit forall points. Hence
- -- we have to remove the implicit forall here.
- let t' = case t of
- L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
- other -> other
- in
- return (SigPatIn e t')
+ -- view pattern is well-formed if the pattern is
+ EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
+ ExprWithTySig e t -> do e <- checkLPat e
+ -- Pattern signatures are parsed as sigtypes,
+ -- but they aren't explicit forall points. Hence
+ -- we have to remove the implicit forall here.
+ let t' = case t of
+ L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
+ other -> other
+ return (SigPatIn e t')
-- 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)
- OpApp l op fix r -> checkLPat l >>= \l ->
- checkLPat r >>= \r ->
- case op of
- L cl (HsVar c) | isDataOcc (rdrNameOcc c)
- -> return (ConPatIn (L cl c) (InfixCon l r))
- _ -> patFail loc
+ OpApp l op _fix r -> do l <- checkLPat l
+ r <- checkLPat r
+ case op of
+ L cl (HsVar c) | isDataOcc (rdrNameOcc c)
+ -> return (ConPatIn (L cl c) (InfixCon l r))
+ _ -> patFail loc
- HsPar e -> checkLPat e >>= (return . ParPat)
- ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
- return (ListPat ps placeHolderType)
- ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
- return (PArrPat ps placeHolderType)
+ HsPar e -> checkLPat e >>= (return . ParPat)
+ ExplicitList _ es -> do ps <- mapM checkLPat es
+ return (ListPat ps placeHolderType)
+ ExplicitPArr _ es -> do ps <- mapM checkLPat es
+ return (PArrPat ps placeHolderType)
- ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
- return (TuplePat ps b placeHolderType)
+ ExplicitTuple es b -> do ps <- mapM checkLPat es
+ return (TuplePat ps b placeHolderType)
- RecordCon c _ (HsRecordBinds fs) -> mapM checkPatField fs >>= \fs ->
- return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
+ RecordCon c _ (HsRecFields fs dd)
+ -> do fs <- mapM checkPatField fs
+ return (ConPatIn c (RecCon (HsRecFields fs dd)))
+ HsQuasiQuoteE q -> return (QuasiQuotePat q)
-- Generics
HsType ty -> return (TypePat ty)
_ -> 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 :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
-checkPatField (n,e) = do
- p <- checkLPat e
- return (n,p)
+checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
+checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
+ ; return (fld { hsRecFieldArg = p }) }
+patFail :: SrcSpan -> P a
patFail loc = parseError loc "Parse error in pattern"
fun is_infix pats opt_sig grhss
Nothing -> checkPatBind lhs grhss }
+checkFunBind :: SrcSpan
+ -> Located RdrName
+ -> Bool
+ -> [LHsExpr RdrName]
+ -> Maybe (LHsType RdrName)
+ -> Located (GRHSs RdrName)
+ -> 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
= FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
+checkPatBind :: LHsExpr RdrName
+ -> Located (GRHSs RdrName)
+ -> P (HsBind RdrName)
checkPatBind lhs (L _ grhss)
= do { lhs <- checkPattern lhs
; return (PatBind lhs grhss placeHolderType placeHolderNames) }
checkValSig (L l (HsVar v)) ty
| isUnqual v && not (isDataOcc (rdrNameOcc v))
= return (TypeSig (L l v) ty)
-checkValSig (L l other) ty
+checkValSig (L l _) _
= parseError l "Invalid type signature"
mkGadtDecl :: Located RdrName
mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
+mk_gadt_con :: Located RdrName
+ -> [LHsTyVarBndr RdrName]
+ -> LHsContext RdrName
+ -> LHsType RdrName
+ -> ConDecl RdrName
mk_gadt_con name qvars cxt ty
= ConDecl { con_name = name
, con_explicit = Implicit
-- 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, b])
-splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
+splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
| op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
where
(arg1,argns) = split_bang r_arg []
split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
split_bang e es = (e,es)
-splitBang other = Nothing
+splitBang _ = Nothing
isFunLhs :: LHsExpr RdrName
-> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
mkRecConstrOrUpdate
:: LHsExpr RdrName
-> SrcSpan
- -> HsRecordBinds RdrName
+ -> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
-> P (HsExpr RdrName)
-mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
- = return (RecordCon (L l c) noPostTcExpr fs)
-mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_))
- = return (RecordUpd exp fs placeHolderType placeHolderType)
-mkRecConstrOrUpdate _ loc (HsRecordBinds [])
- = parseError loc "Empty record update"
+mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
+ = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
+mkRecConstrOrUpdate exp loc (fs,dd)
+ | null fs = parseError loc "Empty record update"
+ | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
-mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
+mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
+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 -> 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
+ vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
+ _ -> d'oh
parse2 isStatic kind xs = parse3 isStatic kind "" xs
parse3 isStatic kind assem [x] =
mkExport :: CallConv
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
-mkExport (CCall cconv) (L loc entity, v, ty) = return $
+mkExport (CCall cconv) (L _ entity, v, ty) = return $
ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
-mkExport DNCall (L loc entity, v, ty) =
+mkExport DNCall (L _ _, v, _) =
parseError (getLoc v){-TODO: not quite right-}
"Foreign export is not yet supported for .NET"
-- 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