ys_list <- coreList nameTyConName ys'
repFunDep xs_list ys_list
-repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now
+repInstD' (L loc (InstDecl ty binds _ _)) -- Ignore user pragmas for now
= do { i <- addTyVarBinds tvs $ \tv_bndrs ->
-- We must bring the type variables into scope, so their occurrences
-- don't fail, even though the binders don't appear in the resulting
= do { stuff <- cvt_tycl_hdr ctxt cl tvs
; fds' <- mapM cvt_fundep fds
; (binds', sigs') <- cvtBindsAndSigs decs
- ; returnL $ TyClD $ mkClassDecl stuff fds' sigs' binds' }
+ ; returnL $ TyClD $ mkClassDecl stuff fds' sigs' binds' []
+ -- ^^no ATs in TH
+ }
cvtTop (InstanceD tys ty decs)
= do { (binds', sigs') <- cvtBindsAndSigs decs
; ctxt' <- cvtContext tys
; L loc pred' <- cvtPred ty
; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
- ; returnL $ InstD (InstDecl inst_ty' binds' sigs') }
+ ; returnL $ InstD (InstDecl inst_ty' binds' sigs' [])
+ -- ^^no ATs in TH
+ }
cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tvs' <- cvtTvs tvs
- ; return (cxt', tc', tvs') }
+ ; return (cxt', tc', tvs', Nothing) }
---------------------------------------------------
-- Data types
isClassDecl, isSynDecl, isDataDecl,
countTyClDecls,
conDetailsTys,
+ instDeclATs,
collectRuleBndrSigTys,
) where
tcdCtxt :: LHsContext name, -- Context
tcdLName :: Located name, -- Type constructor
tcdTyVars :: [LHsTyVarBndr name], -- Type variables
- tcdKindSig :: Maybe Kind, -- Optional kind sig;
+ tcdTyPats :: Maybe [LHsType name], -- Type patterns
+ tcdKindSig:: Maybe Kind, -- Optional kind sig;
-- (only for the 'where' form)
tcdCons :: [LConDecl name], -- Data constructors
tcdTyVars :: [LHsTyVarBndr name], -- Class type variables
tcdFDs :: [Located (FunDep name)], -- Functional deps
tcdSigs :: [LSig name], -- Methods' signatures
- tcdMeths :: LHsBinds name -- Default methods
+ tcdMeths :: LHsBinds name, -- Default methods
+ tcdATs :: [LTyClDecl name] -- Associated types; ie
+ -- only 'TyData'
+ -- and 'TySynonym'
}
data NewOrData
tyClDeclNames (TySynonym {tcdLName = name}) = [name]
tyClDeclNames (ForeignType {tcdLName = name}) = [name]
-tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs})
- = cls_name : [n | L _ (TypeSig n _) <- sigs]
+tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
+ = cls_name :
+ concatMap (tyClDeclNames . unLoc) ats ++ [n | L _ (TypeSig n _) <- sigs]
tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
= tc_name : conDeclsNames (map unLoc cons)
= hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon]
ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
- = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars <+> equals)
+ = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars Nothing <+> equals)
4 (ppr mono_ty)
ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
- tcdTyVars = tyvars, tcdKindSig = mb_sig, tcdCons = condecls,
- tcdDerivs = derivings})
- = pp_tydecl (ppr new_or_data <+> pp_decl_head (unLoc context) ltycon tyvars <+> ppr_sig mb_sig)
+ tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig,
+ tcdCons = condecls, tcdDerivs = derivings})
+ = pp_tydecl (ppr new_or_data <+>
+ pp_decl_head (unLoc context) ltycon tyvars typats <+>
+ ppr_sig mb_sig)
(pp_condecls condecls)
derivings
where
ppr_sig Nothing = empty
ppr_sig (Just kind) = dcolon <+> pprKind kind
- ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFDs = fds,
- tcdSigs = sigs, tcdMeths = methods})
- | null sigs -- No "where" part
+ ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
+ tcdFDs = fds,
+ tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
+ | null sigs && null ats -- No "where" part
= top_matter
| otherwise -- Laid out
= sep [hsep [top_matter, ptext SLIT("where {")],
- nest 4 (sep [sep (map ppr_sig sigs), pprLHsBinds methods, char '}'])]
+ nest 4 (sep [ sep (map ppr_semi ats)
+ , sep (map ppr_semi sigs)
+ , pprLHsBinds methods
+ , char '}'])]
where
- top_matter = ptext SLIT("class") <+> pp_decl_head (unLoc context) lclas tyvars <+> pprFundeps (map unLoc fds)
- ppr_sig sig = ppr sig <> semi
+ top_matter = ptext SLIT("class")
+ <+> pp_decl_head (unLoc context) lclas tyvars Nothing
+ <+> pprFundeps (map unLoc fds)
+ ppr_semi decl = ppr decl <> semi
pp_decl_head :: OutputableBndr name
=> HsContext name
-> Located name
-> [LHsTyVarBndr name]
+ -> Maybe [LHsType name]
-> SDoc
-pp_decl_head context thing tyvars
+pp_decl_head context thing tyvars Nothing -- no explicit type patterns
= hsep [pprHsContext context, ppr thing, interppSP tyvars]
+pp_decl_head context thing _ (Just typats) -- explicit type patterns
+ = hsep [ pprHsContext context, ppr thing
+ , hsep (map (pprParendHsType.unLoc) typats)]
+
pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
= hang (ptext SLIT("where")) 2 (vcat (map ppr cs))
pp_condecls cs -- In H98 syntax
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
(LHsBinds name)
- [LSig name] -- User-supplied pragmatic info
+ [LSig name] -- User-supplied pragmatic info
+ [LTyClDecl name]-- Associated types
instance (OutputableBndr name) => Outputable (InstDecl name) where
- ppr (InstDecl inst_ty binds uprags)
+ ppr (InstDecl inst_ty binds uprags ats)
= vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
+ nest 4 (ppr ats),
nest 4 (ppr uprags),
nest 4 (pprLHsBinds binds) ]
+
+-- Extract the declarations of associated types from an instance
+--
+instDeclATs :: InstDecl name -> [LTyClDecl name]
+instDeclATs (InstDecl _ _ _ ats) = ats
\end{code}
%************************************************************************
(classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
class_info other = (0,0)
- inst_info (InstDecl _ inst_meths inst_sigs)
+ inst_info (InstDecl _ inst_meths inst_sigs _) -- !!!TODO: ATs info -=chak
= case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is) ->
(addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is)
{-
-----------------------------------------------------------------------------
+26 July 2006
+
+Conflicts: 37 shift/reduce
+ 1 reduce/reduce
+
+The reduce/reduce conflict is weird. It's between tyconsym and consym, and I
+would think the two should never occur in the same context.
+
+ -=chak
+
+-----------------------------------------------------------------------------
Conflicts: 36 shift/reduce (1.25)
10 for abiguity in 'if x then y else z + 1' [State 178]
| topdecl { $1 }
topdecl :: { OrdList (LHsDecl RdrName) }
- : tycl_decl { unitOL (L1 (TyClD (unLoc $1))) }
+ : cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
+ | ty_decl {% checkTopTyClD $1 >>= return.unitOL.L1 }
| 'instance' inst_type where
- { let (binds,sigs) = cvBindsAndSigs (unLoc $3)
- in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) }
+ { let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3)
+ in unitOL (L (comb3 $1 $2 $3)
+ (InstD (InstDecl $2 binds sigs ats))) }
| 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
| 'foreign' fdecl { unitOL (LL (unLoc $2)) }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1))
)) }
-tycl_decl :: { LTyClDecl RdrName }
+-- Type classes
+--
+cl_decl :: { LTyClDecl RdrName }
+ : 'class' tycl_hdr fds where
+ {% do { let { (binds, sigs, ats) =
+ cvBindsAndSigs (unLoc $4)
+ ; (ctxt, tc, tvs, Just tparms) = unLoc $2}
+ ; checkTyVars tparms
+ ; return $ L (comb4 $1 $2 $3 $4)
+ (mkClassDecl (ctxt, tc, tvs)
+ (unLoc $3) sigs binds ats) } }
+
+-- Type declarations
+--
+ty_decl :: { LTyClDecl RdrName }
: 'type' type '=' ctype
-- Note type on the left of the '='; this allows
-- infix type constructors to be declared
{ L (comb4 $1 $2 $4 $5)
(mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
- | 'class' tycl_hdr fds where
- { let
- (binds,sigs) = cvBindsAndSigs (unLoc $4)
- in
- L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs
- binds) }
-
data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
| 'newtype' { L1 NewType }
: { Nothing }
| '::' kind { Just $2 }
--- tycl_hdr parses the header of a type or class decl,
+-- tycl_hdr parses the header of a type decl,
-- which takes the form
-- T a b
-- Eq a => T a
-- (Eq a, Ord b) => T a b
+-- T Int [a] -- for associated types
-- Rather a lot of inlining here, else we get reduce/reduce errors
-tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) }
+tycl_hdr :: { Located (LHsContext RdrName,
+ Located RdrName,
+ [LHsTyVarBndr RdrName],
+ Maybe [LHsType RdrName]) }
: context '=>' type {% checkTyClHdr $1 $3 >>= return.LL }
| type {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
-----------------------------------------------------------------------------
-- Nested declarations
+-- Type declaration or value declaration
+--
+tydecl :: { Located (OrdList (LHsDecl RdrName)) }
+tydecl : ty_decl { LL (unitOL (L1 (TyClD (unLoc $1)))) }
+ | decl { $1 }
+
+tydecls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
+ : tydecls ';' tydecl { LL (unLoc $1 `appOL` unLoc $3) }
+ | tydecls ';' { LL (unLoc $1) }
+ | tydecl { $1 }
+ | {- empty -} { noLoc nilOL }
+
+
+tydecllist
+ :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
+ : '{' tydecls '}' { LL (unLoc $2) }
+ | vocurly tydecls close { $2 }
+
+-- Form of the body of class and instance declarations
+--
+where :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
+ -- No implicit parameters
+ -- May have type declarations
+ : 'where' tydecllist { LL (unLoc $2) }
+ | {- empty -} { noLoc nilOL }
+
decls :: { Located (OrdList (LHsDecl RdrName)) }
: decls ';' decl { LL (unLoc $1 `appOL` unLoc $3) }
| decls ';' { LL (unLoc $1) }
: '{' decls '}' { LL (unLoc $2) }
| vocurly decls close { $2 }
-where :: { Located (OrdList (LHsDecl RdrName)) }
- -- No implicit parameters
- : 'where' decllist { LL (unLoc $2) }
- | {- empty -} { noLoc nilOL }
-
+-- Binding groups other than those of class and instance declarations
+--
binds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters
+ -- No type declarations
: decllist { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
| '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
| vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
wherebinds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters
+ -- No type declarations
: 'where' binds { LL (unLoc $2) }
| {- empty -} { noLoc emptyLocalBinds }
tdef :: { TyClDecl RdrName }
: '%data' q_tc_name tv_bndrs '=' '{' cons '}'
- { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) Nothing $6 Nothing }
+ { mkTyData DataType ( noLoc []
+ , noLoc (ifaceExtRdrName $2)
+ , map toHsTvBndr $3
+ , Nothing
+ ) Nothing $6 Nothing }
| '%newtype' q_tc_name tv_bndrs trep
{ let tc_rdr = ifaceExtRdrName $2 in
- mkTyData NewType (noLoc [], noLoc tc_rdr, map toHsTvBndr $3) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
+ mkTyData NewType ( noLoc []
+ , noLoc tc_rdr
+ , map toHsTvBndr $3
+ , Nothing
+ ) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
-- For a newtype we have to invent a fake data constructor name
-- It doesn't matter what it is, because it won't be used
extractHsTyRdrTyVars,
extractHsRhoRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl,
+ mkHsOpApp, mkClassDecl,
mkHsNegApp, mkHsIntegral, mkHsFractional,
mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
checkContext, -- HsType -> P HsContext
checkPred, -- HsType -> P HsPred
checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+ checkTyVars, -- [LHsType RdrName] -> P ()
checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
+ checkTopTyClD, -- LTyClDecl RdrName -> P (HsDecl RdrName)
checkInstType, -- HsType -> P HsType
checkPattern, -- HsExp -> P HsPat
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
= ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
tcdFDs = fds,
tcdSigs = sigs,
- tcdMeths = mbinds
+ tcdMeths = mbinds,
+ tcdATs = ats
}
-mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
+mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
= TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
- tcdTyVars = tyvars, tcdCons = data_cons,
+ tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
tcdKindSig = ksig, tcdDerivs = maybe_deriv }
\end{code}
where (L l' b', ds') = getMonoBind (L l b) ds
go (d : ds) = d : go ds
+-- Declaration list may only contain value bindings and signatures
+--
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
- = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
- ValBindsIn mbs sigs
- }
+ = case cvBindsAndSigs binding of
+ (mbs, sigs, []) -> -- list of type decls *always* empty
+ ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
- -> (Bag (LHsBind RdrName), [LSig RdrName])
+ -> (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
cvBindsAndSigs fb = go (fromOL fb)
where
- go [] = (emptyBag, [])
- go (L l (SigD s) : ds) = (bs, L l s : ss)
- where (bs,ss) = go ds
- go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
- where (b',ds') = getMonoBind (L l b) ds
- (bs,ss) = go ds'
+ go [] = (emptyBag, [], [])
+ go (L l (SigD s) : ds) = (bs, L l s : ss, ts)
+ where (bs, ss, ts) = go ds
+ go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
+ where (b', ds') = getMonoBind (L l b) ds
+ (bs, ss, ts) = go ds'
+ go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
+ where (bs, ss, ts) = go ds
-----------------------------------------------------------------------------
-- Group function bindings into equation groups
ty -> do dict_ty <- checkDictTy (L l ty)
return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
-checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-checkTyVars tvs
- = mapM chk tvs
+-- Check that the given list of type parameters are all type variables
+-- (possibly with a kind signature).
+--
+checkTyVars :: [LHsType RdrName] -> P ()
+checkTyVars tvs = mapM_ chk tvs
where
- -- Check that the name space is correct!
+ -- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
- | isRdrTyVar tv = return (L l (KindedTyVar tv k))
+ | isRdrTyVar tv = return ()
chk (L l (HsTyVar tv))
- | isRdrTyVar tv = return (L l (UserTyVar tv))
+ | isRdrTyVar tv = return ()
chk (L l other)
= parseError l "Type found where type variable expected"
checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
-checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
+checkSynHdr ty = do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
+ ; checkTyVars tparms
; return (tc, tvs) }
checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
- -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+ -> 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'
-- The header of a type or class decl should look like
-- (C a, D b) => T a b
-- or T a b
-- or a + b
-- etc
+-- With associated types, we can also have non-variable parameters; ie,
+-- T Int [a]
+-- The unaltered parameter list is returned in the fourth component of the
+-- result. Eg, for
+-- T Int [a]
+-- we return
+-- ('()', 'T', ['a'], Just ['Int', '[a]'])
checkTyClHdr (L l cxt) ty
- = do (tc, tvs) <- gol ty []
+ = do (tc, tvs, parms) <- gol ty []
mapM_ chk_pred cxt
- return (L l cxt, tc, tvs)
+ return (L l cxt, tc, tvs, Just parms)
where
gol (L l ty) acc = go l ty acc
go l (HsTyVar tc) acc
- | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
- return (L l tc, tvs)
- go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
- return (tc, tvs)
+ | 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 (HsParTy ty) acc = gol ty acc
go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
- go l other acc = parseError l "Malformed LHS to type of class declaration"
+ 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,
chk_pred (L l _)
= parseError l "Malformed context in type or class declaration"
-
+-- Extract the type variables of a list of type parameters.
+--
+-- * Type arguments can be complex type terms (needed for associated type
+-- declarations).
+--
+extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
+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 of a list of types
+ collects tvs [] = return tvs
+ collects tvs (t:ts) = do
+ 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).
+--
+checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName)
+checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) =
+ do
+ checkTyVars typats
+ return $ TyClD d {tcdTyPats = Nothing}
+checkTopTyClD (L _ d) = return $ TyClD d
+
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l t)
= check t
\end{code}
+
%************************************************************************
%* *
\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl,
ForeignDecl(..), HsGroup(..), HsValBinds(..),
Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
+ instDeclATs,
LIE )
import RnEnv
import IfaceEnv ( ifaceExportNames )
import Util ( notNull )
import List ( partition )
import IO ( openFile, IOMode(..) )
+import Monad ( liftM )
\end{code}
*** See "THE NAMING STORY" in HsDecls ****
+Associated data types: Instances declarations may contain definitions of
+associated data types whose data constructors we need to collect, too.
+However, we need to be careful with the handling of the data type constructor
+of each asscociated type, as it is already defined in the corresponding
+class. We make a new name for it, but don't return it in the 'AvailInfo' (to
+avoid raising a duplicate declaration error; see the helper
+'unavail_main_name').
+
\begin{code}
getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [Name]
getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs,
hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
hs_fords = foreign_decls })
= do { tc_names_s <- mappM new_tc tycl_decls
+ ; at_names_s <- mappM inst_ats inst_decls
; val_names <- mappM new_simple val_bndrs
- ; return (foldr (++) val_names tc_names_s) }
+ ; return (foldr (++) val_names (tc_names_s ++ concat at_names_s)) }
where
mod = tcg_mod gbl_env
is_hs_boot = isHsBoot (tcg_src gbl_env) ;
; return (main_name : sub_names) }
where
(main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl)
+
+ inst_ats inst_decl
+ = mappM (liftM tail . new_tc) (instDeclATs (unLoc inst_decl))
+ -- drop main_rdr (already declared in class)
\end{code}
import {-# SOURCE #-} RnExpr( rnLExpr )
import HsSyn
-import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts,
- GlobalRdrElt(..), isLocalGRE )
+import RdrName ( RdrName, isRdrDataCon, isRdrTyVar, elemLocalRdrEnv,
+ globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE )
import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
import DynFlags ( DynFlag(..) )
import Maybes ( seqMaybe )
import Maybe ( isNothing )
+import Monad ( liftM )
import BasicTypes ( Boxity(..) )
\end{code}
<- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
let {
+ rn_at_decls = concat
+ [ats | L _ (InstDecl _ _ _ ats) <- rn_inst_decls] ;
rn_group = HsGroup { hs_valds = rn_val_decls,
- hs_tyclds = rn_tycl_decls,
+ hs_tyclds = rn_tycl_decls ++ rn_at_decls,
hs_instds = rn_inst_decls,
hs_fixds = rn_fix_decls,
hs_depds = [],
%*********************************************************
\begin{code}
-rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
+rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
-- Used for both source and interface file decls
= rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' ->
+ -- Rename the associated types
+ -- The typechecker (not the renamer) checks that all
+ -- the declarations are for the right class
+ let
+ at_doc = text "In the associated types in an instance declaration"
+ at_names = map (head . tyClDeclNames . unLoc) ats
+ (_, rdrCtxt, _, _) = splitHsInstDeclTy (unLoc inst_ty)
+ in
+ checkDupNames at_doc at_names `thenM_`
+ rnATDefs rdrCtxt ats `thenM` \ (ats', at_fvs) ->
+
-- Rename the bindings
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
in
bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' ->
- returnM (InstDecl inst_ty' mbinds' uprags',
- meth_fvs `plusFV` hsSigsFVs uprags'
+ returnM (InstDecl inst_ty' mbinds' uprags' ats',
+ meth_fvs `plusFV` at_fvs
+ `plusFV` hsSigsFVs uprags'
`plusFV` extractHsTyNames inst_ty')
+ -- We return the renamed associated data type declarations so
+ -- that they can be entered into the list of type declarations
+ -- for the binding group, but we also keep a copy in the instance.
+ -- The latter is needed for well-formedness checks in the type
+ -- checker (eg, to ensure that all ATs of the instance actually
+ -- receive a declaration).
+ -- NB: Even the copies in the instance declaration carry copies of
+ -- the instance context after renaming. This is a bit
+ -- strange, but should not matter (and it would be more work
+ -- to remove the context).
+\end{code}
+
+Renaming of the associated data definitions requires adding the instance
+context, as the rhs of an AT declaration may use ATs from classes in the
+context.
+
+\begin{code}
+rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName]
+ -> RnM ([LTyClDecl Name], FreeVars)
+rnATDefs ctxt atDecls =
+ mapFvRn (wrapLocFstM addCtxtAndRename) atDecls
+ where
+ -- The parser won't accept anything, but a data declaration
+ addCtxtAndRename ty@TyData {tcdCtxt = L l tyCtxt} =
+ rnTyClDecl (ty {tcdCtxt = L l (ctxt ++ tyCtxt)})
+ -- The source loc is somewhat half hearted... -=chak
\end{code}
For the method bindings in class and instance decls, we extend the
emptyFVs)
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
- tcdTyVars = tyvars, tcdCons = condecls,
- tcdKindSig = sig, tcdDerivs = derivs})
+ tcdTyVars = tyvars, tcdTyPats = typatsMaybe,
+ tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs})
| is_vanilla -- Normal Haskell data type decl
= ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
-- data type is syntactically illegal
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
do { tycon' <- lookupLocatedTopBndrRn tycon
; context' <- rnContext data_doc context
+ ; typats' <- rnTyPats data_doc typatsMaybe
; (derivs', deriv_fvs) <- rn_derivs derivs
; checkDupNames data_doc con_names
; condecls' <- rnConDecls (unLoc tycon') condecls
- ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
- tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls',
- tcdDerivs = derivs'},
+ ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context',
+ tcdLName = tycon', tcdTyVars = tyvars',
+ tcdTyPats = typats', tcdKindSig = Nothing,
+ tcdCons = condecls', tcdDerivs = derivs'},
delFVs (map hsLTyVarName tyvars') $
extractHsCtxtTyNames context' `plusFV`
- plusFVs (map conDeclFVs condecls') `plusFV`
+ plusFVs (map conDeclFVs condecls') `plusFV`
deriv_fvs) }
| otherwise -- GADT
- = do { tycon' <- lookupLocatedTopBndrRn tycon
+ = ASSERT( null typats ) -- GADTs cannot have type patterns for now
+ do { tycon' <- lookupLocatedTopBndrRn tycon
; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
; tyvars' <- bindTyVarsRn data_doc tyvars
(\ tyvars' -> return tyvars')
; (derivs', deriv_fvs) <- rn_derivs derivs
; checkDupNames data_doc con_names
; condecls' <- rnConDecls (unLoc tycon') condecls
- ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
- tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
- tcdDerivs = derivs'},
+ ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
+ tcdLName = tycon', tcdTyVars = tyvars',
+ tcdTyPats = Nothing, tcdKindSig = sig,
+ tcdCons = condecls', tcdDerivs = derivs'},
plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
where
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
- tcdMeths = mbinds})
+ tcdMeths = mbinds, tcdATs = ats})
= lookupLocatedTopBndrRn cname `thenM` \ cname' ->
-- Tyvars scope over superclass context and method signatures
bindTyVarsRn cls_doc tyvars ( \ tyvars' ->
rnContext cls_doc context `thenM` \ context' ->
rnFds cls_doc fds `thenM` \ fds' ->
+ rnATs tyvars' ats `thenM` \ (ats', ats_fvs) ->
renameSigs okClsDclSig sigs `thenM` \ sigs' ->
- returnM (tyvars', context', fds', sigs')
- ) `thenM` \ (tyvars', context', fds', sigs') ->
+ returnM (tyvars', context', fds', (ats', ats_fvs), sigs')
+ ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') ->
+
+ -- Check for duplicates among the associated types
+ let
+ at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats]
+ in
+ checkDupNames at_doc at_rdr_names_w_locs `thenM_`
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
) `thenM` \ (mbinds', meth_fvs) ->
- returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
- tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
+ returnM (ClassDecl { tcdCtxt = context', tcdLName = cname',
+ tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
+ tcdMeths = mbinds', tcdATs = ats'},
delFVs (map hsLTyVarName tyvars') $
extractHsCtxtTyNames context' `plusFV`
plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
hsSigsFVs sigs' `plusFV`
- meth_fvs)
+ meth_fvs `plusFV`
+ ats_fvs)
where
meth_doc = text "In the default-methods for class" <+> ppr cname
cls_doc = text "In the declaration for class" <+> ppr cname
sig_doc = text "In the signatures for class" <+> ppr cname
+ at_doc = text "In the associated types for class" <+> ppr cname
badGadtStupidTheta tycon
= vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
%*********************************************************
\begin{code}
+-- Although, we are processing type patterns here, all type variables should
+-- already be in scope (they are the same as in the 'tcdTyVars' field of the
+-- type declaration to which these patterns belong)
+--
+rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
+rnTyPats _ Nothing = return Nothing
+rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
+
rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
rnConDecls tycon condecls
= mappM (wrapLocM rnConDecl) condecls
rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs
rnHsTyvar doc tyvar = lookupOccRn tyvar
+
+-- Rename associated data type declarations
+--
+rnATs :: [LHsTyVarBndr Name] -> [LTyClDecl RdrName]
+ -> RnM ([LTyClDecl Name], FreeVars)
+rnATs classLTyVars ats
+ = mapFvRn (wrapLocFstM rn_at) ats
+ where
+ -- The parser won't accept anything, but a data declarations
+ rn_at (tydecl@TyData {tcdCtxt = L ctxtL ctxt, tcdLName = tycon,
+ tcdTyPats = Just typats, tcdCons = condecls,
+ tcdDerivs = derivs}) =
+ do { checkM (null ctxt ) $ addErr atNoCtxt -- no context
+ ; checkM (null condecls) $ addErr atNoCons -- no constructors
+ -- check and collect type parameters
+ ; let (idxParms, excessParms) = splitAt (length classLTyVars) typats
+ ; zipWithM_ cmpTyVar idxParms classLTyVars
+ ; excessTyVars <- liftM catMaybes $ mappM chkTyVar excessParms
+ -- bind excess parameters
+ ; bindTyVarsRn data_doc excessTyVars $ \ excessTyVars' -> do {
+ ; tycon' <- lookupLocatedTopBndrRn tycon
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
+ ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = L ctxtL [],
+ tcdLName = tycon',
+ tcdTyVars = classLTyVars ++ excessTyVars',
+ tcdTyPats = Nothing, tcdKindSig = Nothing,
+ tcdCons = [], tcdDerivs = derivs'},
+ delFVs (map hsLTyVarName (classLTyVars ++ excessTyVars')) $
+ deriv_fvs) } }
+ where
+ -- Check that the name space is correct!
+ cmpTyVar (L l ty@(HsTyVar tv)) classTV = -- just a type variable
+ checkM (rdrNameOcc tv == nameOccName classTVName) $
+ mustMatchErr l ty classTVName
+ where
+ classTVName = hsLTyVarName classTV
+ cmpTyVar (L l ty@(HsKindSig (L _ (HsTyVar tv)) k)) _ | isRdrTyVar tv =
+ noKindSigErr l tv -- additional kind sig not allowed at class parms
+ cmpTyVar (L l otherTy) _ =
+ tyVarExpectedErr l -- parameter must be a type variable
+
+ -- Check that the name space is correct!
+ chkTyVar (L l (HsKindSig (L _ (HsTyVar tv)) k))
+ | isRdrTyVar tv = return $ Just (L l (KindedTyVar tv k))
+ chkTyVar (L l (HsTyVar tv))
+ | isRdrTyVar tv = return $ Just (L l (UserTyVar tv))
+ chkTyVar (L l otherTy) = tyVarExpectedErr l >> return Nothing
+ -- drop parameter; we stop after renaming anyways
+
+ rn_derivs Nothing = returnM (Nothing, emptyFVs)
+ rn_derivs (Just ds) = do
+ ds' <- rnLHsTypes data_doc ds
+ returnM (Just ds', extractHsTyNames_s ds')
+
+ atNoCtxt = text "Associated data type declarations cannot have a context"
+ atNoCons = text "Associated data type declarations cannot have any constructors"
+ data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
+
+noKindSigErr l ty =
+ addErrAt l $
+ sep [ptext SLIT("No kind signature allowed at copies of class parameters:"),
+ nest 2 $ ppr ty]
+
+mustMatchErr l ty classTV =
+ addErrAt l $
+ sep [ptext SLIT("Type variable"), quotes (ppr ty),
+ ptext SLIT("must match corresponding class parameter"),
+ quotes (ppr classTV)]
+
+tyVarExpectedErr l =
+ addErrAt l (ptext SLIT("Type found where type variable expected"))
\end{code}
-- Type-check all the stuff before the "where"
--
-- We check for respectable instance type, and context
-tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
+tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
= -- Prime error recovery, set source location
+ ASSERT( null ats )
+ -- !!!TODO: Handle the `ats' parameter!!! -=chak
recoverM (returnM Nothing) $
setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
import UniqFM ( unitUFM )
import Unique ( Unique )
-import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
+import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set,
+ dopt_unset, GhcMode )
import StaticFlags ( opt_PprStyle_Debug )
import Bag ( snocBag, unionBags )
import Panic ( showException )
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
+unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
+ env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
+
ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is true
ifOptM flag thing_inside = do { b <- doptM flag;
if b then thing_inside else return () }
import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
ConDecl(..), Sig(..), NewOrData(..), ResType(..),
- tyClDeclTyVars, isSynDecl, hsConArgs,
+ tyClDeclTyVars, isSynDecl, isClassDecl, hsConArgs,
LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
)
import HsTypes ( HsBang(..), getBangStrictness )
; traceTc (text "tcTyAndCl" <+> ppr mod)
; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
do { let { -- Calculate variances and rec-flag
- ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls }
+ ; (syn_decls, alg_decls_pre) = partition (isSynDecl . unLoc) decls
+ ; alg_decls = alg_decls_pre ++
+ concat [tcdATs decl -- add AT decls
+ | declLoc <- alg_decls_pre
+ , let decl = unLoc declLoc
+ , isClassDecl decl] }
-- Extend the global env with the knot-tied results
-- for data types and classes
-- going to remove the constructor while coercing it to a lifted type.
-- And newtypes can't be bang'd
+-- !!!TODO -=chak
kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs})
= kcTyClDeclBody decl $ \ tvs' ->
do { is_boot <- tcIsHsBoot
tcTyClDecl1 calc_vrcs calc_isrec
(ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
tcdCtxt = ctxt, tcdMeths = meths,
- tcdFDs = fundeps, tcdSigs = sigs} )
+ tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
= tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
; fds' <- mappM (addLocM tc_fundep) fundeps
+ -- !!!TODO: process `ats`; what do we want to store in the `Class'? -=chak
; sig_stuff <- tcClassSigs class_name sigs meths
; clas <- fixM (\ clas ->
let -- This little knot is just so we can get
-- class has only one parameter. We can't do generic
-- multi-parameter type classes!
; checkTc (unary || no_generics) (genericMultiParamErr cls)
+
+ -- Check that the class has no associated types, unless GlaExs
+ ; checkTc (gla_exts || no_ats) (badATDecl cls)
}
where
(tyvars, theta, _, op_stuff) = classBigSig cls
unary = isSingleton tyvars
no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+ no_ats = True -- !!!TODO: determine whether the class has ATs -=chak
check_op gla_exts (sel_id, dm)
= addErrCtxt (classOpCtxt sel_id tau) $ do
= sep [ptext SLIT("The constructor of a newtype must have exactly one field"),
nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds]
+badATDecl cl_name
+ = vcat [ ptext SLIT("Illegal associated type declaration in") <+> quotes (ppr cl_name)
+ , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow ATs")) ]
+
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")]