Commit b857c8ad authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor HsDecls.TyClDecl to extract the type HsTyDefn, which is the

RHS of a data type or type synonym declaration.  This can be shared
between type declarations and type *instance* declarations.
parent ca7c3a0e
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -33,7 +33,7 @@ module HsUtils(
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkHsBSig,
-- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
......@@ -69,7 +69,7 @@ module HsUtils(
collectSigTysFromPats, collectSigTysFromPat,
hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders,
hsForeignDeclsBinders, hsGroupBinders,
hsForeignDeclsBinders, hsGroupBinders, hsFamInstBinders,
-- Collecting implicit binders
lStmtsImplicits, hsValBindsImplicits, lPatImplicits
......@@ -96,7 +96,6 @@ import Util
import Bag
import Data.Either
import Data.Maybe
\end{code}
......@@ -266,6 +265,9 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
mkHsString :: String -> HsLit
mkHsString s = HsString (mkFastString s)
mkHsBSig :: a -> HsBndrSig a
mkHsBSig x = HsBSig x placeHolderBndrs
-------------
userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
......@@ -622,9 +624,10 @@ hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
-- We need to look at instance declarations too,
-- because their associated types may bind data constructors
hsTyClDeclsBinders tycl_decls inst_decls
= [n | d <- instDeclFamInsts inst_decls ++ concat tycl_decls
, L _ n <- hsLTyClDeclBinders d]
= map unLoc (concatMap (concatMap hsLTyClDeclBinders) tycl_decls ++
concatMap (hsInstDeclBinders . unLoc) inst_decls)
-------------------
hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
-- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
-- The first one is guaranteed to be the name of the decl. For record fields
......@@ -632,24 +635,37 @@ hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
-- occurence. We use the equality to filter out duplicate field names
hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d
-------------------
hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name]
hsTyClDeclBinders (TyFamily {tcdLName = name}) = [name]
hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name]
hsTyClDeclBinders (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
hsTyClDeclBinders (ClassDecl { tcdLName = cls_name, tcdSigs = sigs
, tcdATs = ats, tcdATDefs = fam_insts })
= cls_name :
concatMap hsLTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns]
hsTyClDeclBinders (TySynonym {tcdLName = name, tcdTyPats = mb_pats })
| isJust mb_pats = []
| otherwise = [name]
-- See Note [Binders in family instances]
hsTyClDeclBinders (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats })
| isJust mb_pats = hsConDeclsBinders cons
| otherwise = tc_name : hsConDeclsBinders cons
concatMap hsLTyClDeclBinders ats ++
concatMap (hsFamInstBinders . unLoc) fam_insts ++
[n | L _ (TypeSig ns _) <- sigs, n <- ns]
hsTyClDeclBinders (TyDecl { tcdLName = name, tcdTyDefn = defn })
= name : hsTyDefnBinders defn
-------------------
hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
hsInstDeclBinders (ClsInstD { cid_fam_insts = fis }) = concatMap (hsFamInstBinders . unLoc) fis
hsInstDeclBinders (FamInstD fi) = hsFamInstBinders fi
-------------------
hsFamInstBinders :: Eq name => FamInstDecl name -> [Located name]
hsFamInstBinders (FamInstDecl { fid_defn = defn }) = hsTyDefnBinders defn
-------------------
hsTyDefnBinders :: Eq name => HsTyDefn name -> [Located name]
hsTyDefnBinders (TySynonym {}) = []
hsTyDefnBinders (TyData { td_cons = cons }) = hsConDeclsBinders cons
-- See Note [Binders in family instances]
-------------------
hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
-- See hsTyClDeclBinders for what this does
-- The function is boringly complicated because of the records
......
......@@ -141,7 +141,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,0,1)
data_info (TyData {tcdCons = cs, tcdDerivs = derivs})
data_info (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}})
= (length cs, case derivs of Nothing -> 0
Just ds -> length ds)
data_info _ = (0,0)
......@@ -152,9 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
class_info _ = (0,0)
inst_info (FamInstDecl d) = case countATDecl d of
inst_info (FamInstD d) = case countATDecl d of
(tyd, dtd) -> (0,0,0,tyd,dtd)
inst_info (ClsInstDecl _ inst_meths inst_sigs ats)
inst_info (ClsInstD _ inst_meths inst_sigs ats)
= case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
......@@ -163,10 +163,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(map (count_bind.unLoc) (bagToList inst_meths))),
ss, is, tyDecl, dtDecl)
where
countATDecl (TyData {}) = (0, 1)
countATDecl (TySynonym {}) = (1, 0)
countATDecl d = pprPanic "countATDecl: Unhandled decl"
(ppr d)
countATDecl (FamInstDecl { fid_defn = TyData {} }) = (0, 1)
countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0)
addpr :: (Int,Int) -> Int
add2 :: (Int,Int) -> (Int,Int) -> (Int, Int)
......
......@@ -617,7 +617,7 @@ ty_decl :: { LTyClDecl RdrName }
--
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
{% mkTySynonym (comb2 $1 $4) False $2 $4 }
{% mkTySynonym (comb2 $1 $4) $2 $4 }
-- type family declarations
| 'type' 'family' type opt_kind_sig
......@@ -627,7 +627,7 @@ ty_decl :: { LTyClDecl RdrName }
-- ordinary data type or newtype declaration
| data_or_newtype capi_ctype tycl_hdr constrs deriving
{% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) False $2 $3
{% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3
Nothing (reverse (unLoc $4)) (unLoc $5) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
......@@ -636,7 +636,7 @@ ty_decl :: { LTyClDecl RdrName }
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
deriving
{% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) False $2 $3
{% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3
(unLoc $4) (unLoc $5) (unLoc $6) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
......@@ -647,29 +647,29 @@ ty_decl :: { LTyClDecl RdrName }
inst_decl :: { LInstDecl RdrName }
: 'instance' inst_type where_inst
{ let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) }
{ let (binds, sigs, _, ats, _) = cvBindsAndSigs (unLoc $3)
in L (comb3 $1 $2 $3) (ClsInstD $2 binds sigs ats) }
-- type instance declarations
| 'type' 'instance' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% do { L loc d <- mkTySynonym (comb2 $1 $5) True $3 $5
; return (L loc (FamInstDecl d)) } }
{% do { L loc d <- mkFamInstSynonym (comb2 $1 $5) $3 $5
; return (L loc (FamInstD d)) } }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
{% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True Nothing $3
{% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3
Nothing (reverse (unLoc $4)) (unLoc $5)
; return (L loc (FamInstDecl d)) } }
; return (L loc (FamInstD d)) } }
-- GADT instance declaration
| data_or_newtype 'instance' tycl_hdr opt_kind_sig
gadt_constrlist
deriving
{% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True Nothing $3
{% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3
(unLoc $4) (unLoc $5) (unLoc $6)
; return (L loc (FamInstDecl d)) } }
; return (L loc (FamInstD d)) } }
-- Associated type family declarations
--
......@@ -680,43 +680,45 @@ inst_decl :: { LInstDecl RdrName }
-- declarations without a kind signature cause parsing conflicts with empty
-- data declarations.
--
at_decl_cls :: { LTyClDecl RdrName }
-- type family declarations
at_decl_cls :: { LHsDecl RdrName }
-- family declarations
: 'type' type opt_kind_sig
-- Note the use of type for the head; this allows
-- infix type constructors to be declared.
{% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) }
{% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3)
; return (L loc (TyClD decl)) } }
| 'data' type opt_kind_sig
{% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3)
; return (L loc (TyClD decl)) } }
-- default type instance
| 'type' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% mkTySynonym (comb2 $1 $4) True $2 $4 }
-- data/newtype family declaration
| 'data' type opt_kind_sig
{% mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3) }
{% do { L loc fid <- mkFamInstSynonym (comb2 $1 $4) $2 $4
; return (L loc (InstD (FamInstD fid))) } }
-- Associated type instances
--
at_decl_inst :: { LTyClDecl RdrName }
at_decl_inst :: { LFamInstDecl RdrName }
-- type instance declarations
: 'type' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% mkTySynonym (comb2 $1 $4) True $2 $4 }
{% mkFamInstSynonym (comb2 $1 $4) $2 $4 }
-- data/newtype instance declaration
| data_or_newtype capi_ctype tycl_hdr constrs deriving
{% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $2 $3
Nothing (reverse (unLoc $4)) (unLoc $5) }
{% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3
Nothing (reverse (unLoc $4)) (unLoc $5) }
-- GADT instance declaration
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
deriving
{% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $2 $3
(unLoc $4) (unLoc $5) (unLoc $6) }
{% mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3
(unLoc $4) (unLoc $5) (unLoc $6) }
data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
......@@ -755,7 +757,7 @@ stand_alone_deriving :: { LDerivDecl RdrName }
-- Declaration in class bodies
--
decl_cls :: { Located (OrdList (LHsDecl RdrName)) }
decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) }
decl_cls : at_decl_cls { LL (unitOL $1) }
| decl { $1 }
-- A 'default' signature used with the generic-programming extension
......@@ -786,7 +788,7 @@ where_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
-- Declarations in instance bodies
--
decl_inst :: { Located (OrdList (LHsDecl RdrName)) }
decl_inst : at_decl_inst { LL (unitOL (L1 (TyClD (unLoc $1)))) }
decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (FamInstD (unLoc $1))))) }
| decl { $1 }
decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
......
......@@ -127,18 +127,18 @@ tdefs :: { [TyClDecl RdrName] }
tdef :: { TyClDecl RdrName }
: '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
{ TyData { tcdND = DataType, tcdCtxt = noLoc []
, tcdLName = noLoc (ifaceExtRdrName $2)
, tcdTyVars = map toHsTvBndr $3
, tcdTyPats = Nothing, tcdKindSig = Nothing
, tcdCons = $6, tcdDerivs = Nothing } }
{ TyDecl { tcdLName = noLoc (ifaceExtRdrName $2)
, tcdTyVars = map toHsTvBndr $3
, tcdTyDefn = TyData { td_ND = DataType, td_ctxt = noLoc []
, td_kindSig = Nothing
, td_cons = $6, td_derivs = Nothing } } }
| '%newtype' q_tc_name tv_bndrs trep ';'
{ let tc_rdr = ifaceExtRdrName $2 in
TyData { tcdND = NewType, tcdCtxt = noLoc []
, tcdLName = noLoc tc_rdr
, tcdTyVars = map toHsTvBndr $3
, tcdTyPats = Nothing, tcdKindSig = Nothing
, tcdCons = $4 (rdrNameOcc tc_rdr), tcdDerivs = Nothing } }
{ let tc_rdr = ifaceExtRdrName $2 in
TyDecl { tcdLName = noLoc tc_rdr
, tcdTyVars = map toHsTvBndr $3
, tcdTyDefn = TyData { td_ND = NewType, td_ctxt = noLoc []
, td_kindSig = Nothing
, td_cons = $4 (rdrNameOcc tc_rdr), td_derivs = 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
......
This diff is collapsed.
......@@ -22,7 +22,7 @@ module RnEnv (
HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupSubBndrOcc, lookupTcdName,
lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName,
greRdrName,
lookupSubBndrGREs, lookupConstructorFields,
lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse,
......@@ -272,22 +272,13 @@ lookupInstDeclBndr cls what rdr
-----------------------------------------------
lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
-- Used for TyData and TySynonym only,
-- both ordinary ones and family instances
lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name)
-- Used for TyData and TySynonym family instances only,
-- See Note [Family instance binders]
lookupTcdName mb_cls tc_decl
| not (isFamInstDecl tc_decl) -- The normal case
= ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this
lookupLocatedTopBndrRn tc_rdr
| Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind
lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f RnBinds.rnMethodBind
= wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr
| otherwise -- Family instance; tc_rdr is an *occurrence*
lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence*
= lookupLocatedOccRn tc_rdr
where
tc_rdr = tcdLName tc_decl
-----------------------------------------------
lookupConstructorFields :: Name -> RnM [Name]
......
......@@ -529,10 +529,10 @@ getLocalNonValBinders fixity_env
; return (AvailTC main_name names) }
new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
new_assoc (L _ (FamInstDecl d))
new_assoc (L _ (FamInstD d))
= do { avail <- new_ti Nothing d
; return [avail] }
new_assoc (L _ (ClsInstDecl inst_ty _ _ ats))
new_assoc (L _ (ClsInstD { cid_poly_ty = inst_ty, cid_fam_insts = ats }))
| Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
= do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
; mapM (new_ti (Just cls_nm) . unLoc) ats }
......@@ -542,9 +542,8 @@ getLocalNonValBinders fixity_env
new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo
new_ti mb_cls ti_decl -- ONLY for type/data instances
= ASSERT( isFamInstDecl ti_decl )
do { main_name <- lookupTcdName mb_cls ti_decl
; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl)
= do { main_name <- lookupFamInstName mb_cls (fid_tycon ti_decl)
; sub_names <- mapM newTopSrcBinder (hsFamInstBinders ti_decl)
; return (AvailTC (unLoc main_name) sub_names) }
-- main_name is not bound here!
\end{code}
......
This diff is collapsed.
......@@ -26,7 +26,7 @@ module RnTypes (
rnSplice, checkTH,
-- Binding related stuff
bindSigTyVarsFV, bindHsTyVars, bindTyClTyVars, rnHsBndrSig
bindSigTyVarsFV, bindHsTyVars, bindTyVarsRn, rnHsBndrSig
) where
import {-# SOURCE #-} RnExpr( rnLExpr )
......@@ -36,7 +36,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
import DynFlags
import HsSyn
import RdrHsSyn ( extractHsRhoRdrTyVars, extractHsTyRdrTyVars )
import RdrHsSyn ( extractHsTyRdrTyVars, extractHsTysRdrTyVars )
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import TcRnMonad
......@@ -121,14 +121,14 @@ rnHsKind = rnHsTyKi False
rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty)
rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty)
= ASSERT ( isType ) do
-- Implicit quantifiction in source code (no kinds on tyvars)
-- Given the signature C => T we universally quantify
-- over FV(T) \ {in-scope-tyvars}
name_env <- getLocalRdrEnv
let
mentioned = extractHsRhoRdrTyVars ctxt ty
mentioned = extractHsTysRdrTyVars (ty:ctxt)
-- Don't quantify over type variables that are in scope;
-- when GlasgowExts is off, there usually won't be any, except for
......@@ -137,17 +137,17 @@ rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty)
forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
tyvar_bndrs = userHsTyVarBndrs forall_tyvars
rnForAll doc Implicit tyvar_bndrs ctxt ty
rnForAll doc Implicit tyvar_bndrs lctxt ty
rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau)
rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau)
= ASSERT ( isType ) do { -- Explicit quantification.
-- Check that the forall'd tyvars are actually
-- mentioned in the type, and produce a warning if not
let mentioned = extractHsRhoRdrTyVars ctxt tau
let mentioned = extractHsTysRdrTyVars (tau:ctxt)
in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
; rnForAll doc Explicit forall_tyvars ctxt tau }
; rnForAll doc Explicit forall_tyvars lctxt tau }
rnHsTyKi isType _ (HsTyVar rdr_name)
= do { name <- rnTyVar isType rdr_name
......@@ -330,56 +330,6 @@ bindSigTyVarsFV tvs thing_inside
else
bindLocalNamesFV tvs thing_inside }
---------------
bindTyClTyVars
:: HsDocContext
-> Maybe (Name, [Name]) -- Parent class and its tyvars
-- (but not kind vars)
-> [LHsTyVarBndr RdrName]
-> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-- Used for tyvar binders in type/class declarations
-- Just like bindHsTyVars, but deals with the case of associated
-- types, where the type variables may be already in scope
bindTyClTyVars doc mb_cls tyvars thing_inside
| Just (_, cls_tvs) <- mb_cls -- Associated type family or type instance
= do { let tv_rdr_names = map hsLTyVarLocName tyvars
-- *All* the free vars of the family patterns
-- Check for duplicated bindings
-- This test is irrelevant for data/type *instances*, where the tyvars
-- are the free tyvars of the patterns, and hence have no duplicates
-- But it's needed for data/type *family* decls
; checkDupRdrNames tv_rdr_names
-- Make the Names for the tyvars
; rdr_env <- getLocalRdrEnv
; let mk_tv_name :: Located RdrName -> RnM Name
-- Use the same Name as the parent class decl
mk_tv_name (L l tv_rdr)
= case lookupLocalRdrEnv rdr_env tv_rdr of
Just n -> return n
Nothing -> newLocalBndrRn (L l tv_rdr)
; tv_ns <- mapM mk_tv_name tv_rdr_names
; (thing, fvs) <- bindTyVarsRn doc tyvars tv_ns thing_inside
-- See Note [Renaming associated types]
; let bad_tvs = fvs `intersectNameSet` mkNameSet cls_tvs
; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs))
; return (thing, fvs) }
| otherwise -- Not associated, just fall through to bindHsTyVars
= bindHsTyVars doc tyvars thing_inside
badAssocRhs :: [Name] -> RnM ()
badAssocRhs ns
= addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable")
<> plural ns
<+> pprWithCommas (quotes . ppr) ns)
2 (ptext (sLit "All such variables must be bound on the LHS")))
---------------
bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName]
-> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
......
......@@ -404,18 +404,7 @@ tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
tcAddDeclCtxt decl thing_inside
= addErrCtxt ctxt thing_inside
where
thing | isClassDecl decl = "class"
| isTypeDecl decl = "type synonym" ++ maybeInst
| isDataDecl decl = if tcdND decl == NewType
then "newtype" ++ maybeInst
else "data type" ++ maybeInst
| isFamilyDecl decl = "family"
| otherwise = panic "tcAddDeclCtxt/thing"
maybeInst | isFamInstDecl decl = " instance"
| otherwise = ""
ctxt = hsep [ptext (sLit "In the"), text thing,
ctxt = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
badMethodErr :: Outputable a => a -> Name -> SDoc
......
......@@ -23,7 +23,7 @@ import DynFlags
import TcRnMonad
import FamInst
import TcEnv
import TcTyClsDecls( tcFamTyPats )
import TcTyClsDecls( tcFamTyPats, tcAddFamInstCtxt )
import TcClassDcl( tcAddDeclCtxt ) -- Small helper
import TcGenDeriv -- Deriv stuff
import TcGenGenerics
......@@ -447,27 +447,58 @@ makeDerivSpecs :: Bool
-> [LDerivDecl Name]
-> TcM [EarlyDerivSpec]
makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
| is_boot -- No 'deriving' at all in hs-boot files
= do { mapM_ add_deriv_err deriv_locs
; return [] }
| otherwise
= do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
; return (eqns1 ++ eqns2) }
= do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls
; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls
; eqns3 <- mapAndRecoverM deriveStandalone deriv_decls
; let eqns = eqns1 ++ eqns2 ++ eqns3
; if is_boot then -- No 'deriving' at all in hs-boot files
do { unless (null eqns) (add_deriv_err (head eqns))
; return [] }
else return eqns }
where
extractTyDataPreds decls
= [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
add_deriv_err eqn
= setSrcSpan loc $
addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
2 (ptext (sLit "Use an instance declaration instead")))
where
loc = case eqn of { Left ds -> ds_loc ds; Right ds -> ds_loc ds }
all_tydata :: [(LHsType Name, LTyClDecl Name)]
-- Derived predicate paired with its data type declaration
all_tydata = extractTyDataPreds (instDeclFamInsts inst_decls ++ tycl_decls)
------------------------------------------------------------------
deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec]
deriveTyDecl (L _ decl@(TyDecl { tcdLName = L _ tc_name
, tcdTyDefn = TyData { td_derivs = Just preds } }))
= tcAddDeclCtxt decl $
do { tc <- tcLookupTyCon tc_name
; let tvs = tyConTyVars tc
tys = mkTyVarTys tvs
; mapM (deriveTyData tvs tc tys) preds }
deriv_locs = map (getLoc . snd) all_tydata
++ map getLoc deriv_decls
deriveTyDecl _ = return []
add_deriv_err loc = setSrcSpan loc $
addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
2 (ptext (sLit "Use an instance declaration instead")))
------------------------------------------------------------------
deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
deriveInstDecl (L _ (FamInstD fam_inst))
= deriveFamInst fam_inst
deriveInstDecl (L _ (ClsInstD { cid_fam_insts = fam_insts }))
= concatMapM (deriveFamInst . unLoc) fam_insts
------------------------------------------------------------------
deriveFamInst :: FamInstDecl Name -> TcM [EarlyDerivSpec]
deriveFamInst decl@(FamInstDecl { fid_tycon = L _ tc_name, fid_pats = pats
, fid_defn = TyData { td_derivs = Just preds } })
= tcAddFamInstCtxt decl $
do { fam_tc <- tcLookupTyCon tc_name
; tcFamTyPats fam_tc pats (\_ -> return ()) $ \ tvs' pats' _ ->
mapM (deriveTyData tvs' fam_tc pats') preds }
-- Tiresomely we must figure out the "lhs", which is awkward for type families
-- E.g. data T a b = .. deriving( Eq )
-- Here, the lhs is (T a b)
-- data instance TF Int b = ... deriving( Eq )
-- Here, the lhs is (TF Int b)
-- But if we just look up the tycon_name, we get is the *family*
-- tycon, but not pattern types -- they are in the *rep* tycon.
deriveFamInst _ = return []
------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
......@@ -496,16 +527,14 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
(Just theta) }
------------------------------------------------------------------
deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
deriveTyData :: [TyVar] -> TyCon -> [Type]
-> LHsType Name -- The deriving predicate
-> TcM EarlyDerivSpec
-- The deriving clause of a data or newtype declaration
deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
tcdTyVars = hs_tvs,
tcdTyPats = ty_pats }))
deriveTyData tvs tc tc_args (L loc deriv_pred)
= setSrcSpan loc $ -- Use the location of the 'deriving' item
tcAddDeclCtxt decl $
do { (tvs, tc, tc_args) <- get_lhs ty_pats
; tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
-- The "deriv_pred" is a LHsType to take account of the fact that for
......@@ -525,7 +554,8 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs)
`minusVarSet` dropped_tvs
; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$ pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty)
; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$
pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty)
-- Check that the result really is well-kinded
; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
......@@ -547,25 +577,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
(typeFamilyPapErr tc cls cls_tys inst_ty)
; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } }
where
-- Tiresomely we must figure out the "lhs", which is awkward for type families
-- E.g. data T a b = .. deriving( Eq )
-- Here, the lhs is (T a b)
-- data instance TF Int b = ... deriving( Eq )
-- Here, the lhs is (TF Int b)
-- But if we just look up the tycon_name, we get is the *family*
-- tycon, but not pattern types -- they are in the *rep* tycon.
get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name
; let tvs = tyConTyVars tc
; return (tvs, tc, mkTyVarTys tvs) }
get_lhs (Just pats) = do { fam_tc <- tcLookupTyCon tycon_name
; tcFamTyPats fam_tc hs_tvs pats (\_ -> return ()) $
\ tvs' pats' _ ->
return (tvs', fam_tc, pats') }
deriveTyData _other
= panic "derivTyData" -- Caller ensures that only TyData can happen
; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing }
\end{code}
Note [Deriving, type families, and partial applications]
......
......@@ -443,13 +443,14 @@ tcLocalInstDecl1 :: LInstDecl Name
-- Type-check all the stuff before the "where"
--
-- We check for respectable instance type, and context
tcLocalInstDecl1 (L loc (FamInstDecl decl))
tcLocalInstDecl1 (L loc (FamInstD decl))
= setSrcSpan loc $
tcAddDeclCtxt decl $
tcAddFamInstCtxt decl $
do { fam_inst <- tcFamInstDecl TopLevel decl
; return ([], [fam_inst]) }
tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats))
tcLocalInstDecl1 (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds
, cid_sigs = uprags, cid_fam_insts = ats }))
= setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
......@@ -468,7 +469,7 @@ tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats))
-- Check for missing associated types and build them
-- from their defaults (if available)
; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats
; let defined_ats = mkNameSet $ map famInstDeclName ats
mk_deflt_at_instances :: ClassATItem -> TcM [FamInst]
mk_deflt_at_instances (fam_tc, defs)
......@@ -522,12 +523,12 @@ lot of kinding and type checking code with ordinary algebraic data types (and
GADTs).
\begin{code}
tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM FamInst
tcFamInstDecl :: TopLevelFlag -> FamInstDecl Name -> TcM FamInst
tcFamInstDecl top_lvl decl
= do { -- Type family instances require -XTypeFamilies
-- and can't (currently) be in an hs-boot file
; traceTc "tcFamInstDecl" (ppr decl)
; let fam_tc_lname = tcdLName decl
; let fam_tc_lname = fid_tycon decl
; type_families <- xoptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl fam_tc_lname
......@@ -544,10 +545,11 @@ tcFamInstDecl top_lvl decl
-- This is where type and data decls are treated separately
; tcFamInstDecl1 fam_tc decl }
tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM FamInst
tcFamInstDecl1 :: TyCon -> FamInstDecl Name -> TcM FamInst
-- "type instance"
tcFamInstDecl1 fam_tc (decl@TySynonym {})
tcFamInstDecl1 fam_tc decl@(FamInstDecl { fid_tycon = fam_tc_name
, fid_defn = TySynonym {} })
= do { -- (1) do the work of verifying the synonym
; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl
......@@ -555,21 +557,22 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {})
; checkValidFamInst t_typats t_rhs
-- (3) construct representation tycon
; rep_tc_name <- newFamInstAxiomName (tcdLName decl) t_typats
; rep_tc_name <- newFamInstAxiomName fam_tc_name t_typats
; return (mkSynFamInst rep_tc_name t_tvs fam_tc t_typats t_rhs) }
-- "newtype instance" and "data instance"
tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType
, tcdCtxt = ctxt
, tcdTyVars = tvs, tcdTyPats = Just pats
, tcdCons = cons})
tcFamInstDecl1 fam_tc
(FamInstDecl { fid_pats = pats
, fid_tycon = fam_tc_name
, fid_defn = defn@TyData { td_ND = new_or_data, td_cType = cType
, td_ctxt = ctxt, td_cons = cons } })
= do { -- Check that the family declaration is for the right kind
checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
-- Kind check type patterns
; tcFamTyPats fam_tc tvs pats (kcDataDecl decl) $
; tcFamTyPats fam_tc pats (kcTyDefn defn) $
\tvs' pats' res_kind -> do
-- Check that left-hand side contains no type family applications
......@@ -581,10 +584,10 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType
; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc)
; stupid_theta <- tcHsContext ctxt
; dataDeclChecks (tcdName decl) new_or_data stupid_theta cons
; dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
-- Construct representation tycon
; rep_tc_name <- newFamInstTyConName (tcdLName decl) pats'
; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc
; let ex_ok = True -- Existentials ok for type families!
orig_res_ty = mkTyConApp fam_tc pats'
......@@ -615,17 +618,15 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType
L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
_ -> True
tcFamInstDecl1 _ d = pprPanic "tcFamInstDecl1" (ppr d)