Commit afef3973 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Migrate cvs diff from fptools-assoc branch

Wed Jul 26 17:46:55 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Migrate cvs diff from fptools-assoc branch
  - Syntactic support for associated types
  - Renamer support for associated types
  - ATs are only allowed with -fglasgow-exts
  - Handle ATs in the type and class declaration kinding knot-tying exercise
parent 3cec5683
......@@ -231,7 +231,7 @@ repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
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
......
......@@ -128,14 +128,18 @@ cvtTop (ClassD ctxt cl tvs fds decs)
= 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' }
......@@ -143,7 +147,7 @@ cvt_tycl_hdr cxt tc tvs
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tvs' <- cvtTvs tvs
; return (cxt', tc', tvs') }
; return (cxt', tc', tvs', Nothing) }
---------------------------------------------------
-- Data types
......
......@@ -21,6 +21,7 @@ module HsDecls (
isClassDecl, isSynDecl, isDataDecl,
countTyClDecls,
conDetailsTys,
instDeclATs,
collectRuleBndrSigTys,
) where
......@@ -341,7 +342,8 @@ data TyClDecl name
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
......@@ -367,7 +369,10 @@ data TyClDecl name
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
......@@ -406,8 +411,9 @@ tyClDeclNames :: Eq name => TyClDecl name -> [Located name]
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)
......@@ -442,38 +448,51 @@ instance OutputableBndr name
= 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
......@@ -595,14 +614,21 @@ data InstDecl name
-- 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}
%************************************************************************
......
......@@ -132,7 +132,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _))
(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)
......
......@@ -44,6 +44,17 @@ import GLAEXTS
}
{-
-----------------------------------------------------------------------------
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)
......@@ -430,10 +441,12 @@ topdecls :: { OrdList (LHsDecl RdrName) }
| 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 }
......@@ -446,7 +459,21 @@ topdecl :: { OrdList (LHsDecl RdrName) }
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
......@@ -469,13 +496,6 @@ tycl_decl :: { LTyClDecl RdrName }
{ 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 }
......@@ -484,19 +504,49 @@ opt_kind_sig :: { Maybe Kind }
: { 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) }
......@@ -508,17 +558,16 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) }
: '{' 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 }
......
......@@ -88,10 +88,18 @@ tdefs :: { [TyClDecl RdrName] }
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
......
......@@ -8,7 +8,7 @@ module RdrHsSyn (
extractHsTyRdrTyVars,
extractHsRhoRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl,
mkHsOpApp, mkClassDecl,
mkHsNegApp, mkHsIntegral, mkHsFractional,
mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
......@@ -36,7 +36,9 @@ module RdrHsSyn (
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]
......@@ -155,12 +157,13 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
= 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}
......@@ -198,23 +201,29 @@ cvTopDecls decls = go (fromOL decls)
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
......@@ -368,44 +377,61 @@ checkInstType (L l t)
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,
......@@ -414,7 +440,63 @@ checkTyClHdr (L l cxt) ty
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
......
......@@ -468,6 +468,7 @@ rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _))
\end{code}
%************************************************************************
%* *
\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
......
......@@ -17,6 +17,7 @@ import DynFlags ( DynFlag(..), GhcMode(..), DynFlags(..) )
import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl,
ForeignDecl(..), HsGroup(..), HsValBinds(..),
Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
instDeclATs,
LIE )
import RnEnv
import IfaceEnv ( ifaceExportNames )
......@@ -57,6 +58,7 @@ import DriverPhases ( isHsBoot )
import Util ( notNull )
import List ( partition )
import IO ( openFile, IOMode(..) )
import Monad ( liftM )
\end{code}
......@@ -409,14 +411,24 @@ used for source 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) ;
......@@ -437,6 +449,10 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs,
; 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}
......
This diff is collapsed.
......@@ -175,8 +175,10 @@ tcLocalInstDecl1 :: LInstDecl Name
-- 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) $
......
......@@ -50,7 +50,8 @@ import Outputable
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 )
......@@ -268,6 +269,10 @@ setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
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 () }
......
......@@ -12,7 +12,7 @@ module TcTyClsDecls (
import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
ConDecl(..), Sig(..), NewOrData(..), ResType(..),
tyClDeclTyVars, isSynDecl, hsConArgs,
tyClDeclTyVars, isSynDecl, isClassDecl, hsConArgs,
LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
)
import HsTypes ( HsBang(..), getBangStrictness )
......@@ -127,7 +127,12 @@ tcTyAndClassDecls boot_details decls
; 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
......@@ -320,6 +325,7 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
-- 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
......@@ -434,10 +440,11 @@ tcTyClDecl1 calc_vrcs calc_isrec
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
......@@ -704,11 +711,15 @@ checkValidClass cls
-- 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
......@@ -820,6 +831,10 @@ newtypeFieldErr con_name n_flds
= 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)")]
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment