checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPred, -- HsType -> P HsPred
- checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
- checkTyVars, -- [LHsType RdrName] -> Bool -> P ()
- checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
- checkTopTyClD, -- LTyClDecl RdrName -> P (HsDecl 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 ()
checkInstType, -- HsType -> P HsType
+ checkDerivDecl, -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
checkPattern, -- HsExp -> P HsPat
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
checkDo, -- [Stmt] -> P [Stmt]
isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace )
import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
-import Lexer ( P, failSpanMsgP, extension, bangPatEnabled )
+import Lexer ( P, failSpanMsgP, extension, glaExtsEnabled, bangPatEnabled )
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
DNCallSpec(..), DNKind(..), CLabelString )
import Panic
import List ( isSuffixOf, nubBy )
+import Monad ( unless )
\end{code}
-> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])
-- Input decls contain just value bindings and signatures
-- and in case of class or instance declarations also
--- associated data or synonym definitions
+-- associated type declarations
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = (emptyBag, [], [])
-- The rest are routine
add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
= addl (gp { hs_instds = L l d : ts }) ds
+add gp@(HsGroup {hs_derivds = ts}) l (DerivD 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}) l (ForD d) ds
return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
-- Check whether the given list of type parameters are all type variables
--- (possibly with a kind signature). If the second argument is `False', we
+-- (possibly with a kind signature). If the second argument is `False',
-- only type variables are allowed and we raise an error on encountering a
--- non-variable; otherwise, we return the entire list parameters iff at least
--- one is not a variable.
+-- non-variable; otherwise, we allow non-variable arguments and return the
+-- entire list of parameters.
--
-checkTyVars :: [LHsType RdrName] -> Bool -> P (Maybe [LHsType RdrName])
-checkTyVars tparms nonVarsOk =
- do
- areVars <- mapM chk tparms
- return $ if and areVars then Nothing else Just tparms
+checkTyVars :: [LHsType RdrName] -> P ()
+checkTyVars tparms = mapM_ chk tparms
where
-- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
- | isRdrTyVar tv = return True
+ | isRdrTyVar tv = return ()
chk (L l (HsTyVar tv))
- | isRdrTyVar tv = return True
- chk (L l other)
- | nonVarsOk = return False
- | otherwise =
+ | isRdrTyVar tv = return ()
+ chk (L l other) =
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.
+-- all patterns. If yes, we return 'Nothing' as the third component to
+-- indicate a vanilla type synonym.
--
checkSynHdr :: LHsType RdrName
- -> Bool -- non-variables admitted?
+ -> Bool -- is type instance?
-> P (Located RdrName, -- head symbol
[LHsTyVarBndr RdrName], -- parameters
- Maybe [LHsType RdrName]) -- type patterns
-checkSynHdr ty nonVarsOk =
- do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
- ; typats <- checkTyVars tparms nonVarsOk
- ; return (tc, tvs, typats) }
+ [LHsType RdrName]) -- type patterns
+checkSynHdr ty isTyInst =
+ do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
+ ; unless isTyInst $ checkTyVars tparms
+ ; return (tc, tvs, tparms) }
-- Well-formedness check and decomposition of type and class heads.
-> P (LHsContext RdrName, -- the type context
Located RdrName, -- the head symbol (type or class name)
[LHsTyVarBndr RdrName], -- free variables of the non-context part
- Maybe [LHsType RdrName]) -- parameters of head symbol; wrapped into
- -- 'Maybe' for 'mkTyData'
+ [LHsType RdrName]) -- parameters of head symbol
-- The header of a type or class decl should look like
-- (C a, D b) => T a b
-- or T a b
-- result. Eg, for
-- T Int [a]
-- we return
--- ('()', 'T', ['a'], Just ['Int', '[a]'])
+-- ('()', 'T', ['a'], ['Int', '[a]'])
checkTyClHdr (L l cxt) ty
= do (tc, tvs, parms) <- gol ty []
mapM_ chk_pred cxt
- return (L l cxt, tc, tvs, Just parms)
+ return (L l cxt, tc, tvs, parms)
where
gol (L l ty) acc = go l ty acc
tvs' <- collects tvs ts
collect tvs' t
--- Wrap a toplevel type or class declaration into 'TyClDecl' after ensuring
--- that all type parameters are variables only (which is in contrast to
--- associated type declarations).
+-- Check that associated type declarations of a class are all kind signatures.
--
-checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName)
-checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) =
- do
- checkTyVars typats False
- return $ TyClD d {tcdTyPats = Nothing}
-checkTopTyClD (L _ d) = return $ TyClD d
+checkKindSigs :: [LTyClDecl RdrName] -> P ()
+checkKindSigs = mapM_ check
+ where
+ check (L l tydecl)
+ | isKindSigDecl tydecl
+ || isSynDecl tydecl = return ()
+ | otherwise =
+ parseError l "Type declaration in a class must be a kind signature or synonym default"
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l t)
check (HsParTy t) args = check (unLoc t) args
check _ _ = parseError spn "Malformed context in instance header"
+
+---------------------------------------------------------------------------
+-- Checking stand-alone deriving declarations
+
+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)"
+
---------------------------------------------------------------------------
-- Checking statements in a do-expression
-- We parse do { e1 ; e2 ; }
-- 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 = idCoercion, bind_fvs = placeHolderNames }
+ fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames }
checkPatBind lhs (L _ grhss)
= do { lhs <- checkPattern lhs
projects / ghc-hetmet.git / blobdiff