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

HsSyn clean up for indexed types

- This patch cleans up the HsSyn representation of type family declarations.
- The new representation is not only less delicate, it also simplified teh code
  a bit.
- I took the opportunity of stream lining the terminology and function names
  at the same time.
- I also updated the description on the wiki at
  <http://hackage.haskell.org/trac/ghc/wiki/TypeFunctionsSyntax>
parent 3548802d
......@@ -12,6 +12,7 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
module HsDecls (
HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl,
InstDecl(..), LInstDecl, DerivDecl(..), LDerivDecl, NewOrData(..),
FamilyFlavour(..),
RuleDecl(..), LRuleDecl, RuleBndr(..),
DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
......@@ -21,8 +22,8 @@ module HsDecls (
DeprecDecl(..), LDeprecDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
tcdName, tyClDeclNames, tyClDeclTyVars,
isClassDecl, isTFunDecl, isSynDecl, isDataDecl, isKindSigDecl,
isIdxTyDecl,
isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
isFamInstDecl,
countTyClDecls,
conDetailsTys,
instDeclATs,
......@@ -346,13 +347,9 @@ Interface file code:
\begin{code}
-- Representation of indexed types
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Kind signatures of indexed types come in two flavours:
--
-- * kind signatures for type functions: variant `TyFunction' and
--
-- * kind signatures for indexed data types and newtypes : variant `TyData'
-- iff a kind is present in `tcdKindSig' and there are no constructors in
-- `tcdCons'.
-- Family kind signatures are represented by the variant `TyFamily'. It
-- covers "type family", "newtype family", and "data family" declarations,
-- distinguished by the value of the field `tcdFlavour'.
--
-- Indexed types are represented by 'TyData' and 'TySynonym' using the field
-- 'tcdTyPats::Maybe [LHsType name]', with the following meaning:
......@@ -361,7 +358,7 @@ Interface file code:
-- synonym declaration and 'tcdVars' contains the type parameters of the
-- type constructor.
--
-- * If it is 'Just pats', we have the definition of an indexed type Then,
-- * If it is 'Just pats', we have the definition of an indexed type. Then,
-- 'pats' are type patterns for the type-indexes of the type constructor
-- and 'tcdVars' are the variables in those patterns. Hence, the arity of
-- the indexed type (ie, the number of indexes) is 'length tcdTyPats' and
......@@ -376,7 +373,13 @@ data TyClDecl name
tcdLName :: Located name,
tcdExtName :: Maybe FastString,
tcdFoType :: FoType
}
}
| TyFamily { tcdFlavour:: FamilyFlavour, -- type, new, or data
tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
tcdKind :: Maybe Kind -- result kind
}
| TyData { tcdND :: NewOrData,
tcdCtxt :: LHsContext name, -- Context
......@@ -390,12 +393,8 @@ data TyClDecl name
-- Nothing for everything else
tcdKindSig:: Maybe Kind, -- Optional kind sig
-- (Just k) for a
-- (a) GADT-style 'data', or 'data instance' decl
-- with explicit kind sig
-- (b) 'data family' decl, whether or not
-- there is an explicit kind sig
-- (this is how we distinguish a data family decl)
-- (Just k) for a GADT-style 'data', or 'data
-- instance' decl with explicit kind sig
tcdCons :: [LConDecl name], -- Data constructors
-- For data T a = T1 | T2 a the LConDecls all have ResTyH98
......@@ -409,18 +408,9 @@ data TyClDecl name
-- Typically the foralls and ty args are empty, but they
-- are non-empty for the newtype-deriving case
}
-- data family: tcdPats = Nothing, tcdCons = [], tcdKindSig = Just k
--
-- data instance: tcdPats = Just tys
--
-- data: tcdPats = Nothing,
-- tcdCons is non-empty *or* tcdKindSig = Nothing
| TyFunction {tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
tcdIso :: Bool, -- injective type?
tcdKind :: Kind -- result kind
}
| TySynonym { tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
......@@ -445,46 +435,46 @@ data TyClDecl name
}
data NewOrData
= NewType -- "newtype Blah ..."
| DataType -- "data Blah ..."
deriving( Eq ) -- Needed because Demand derives Eq
= NewType -- "newtype Blah ..."
| DataType -- "data Blah ..."
deriving( Eq ) -- Needed because Demand derives Eq
data FamilyFlavour
= TypeFamily -- "type family ..."
| DataFamily NewOrData -- "newtype family ..." or "data family ..."
\end{code}
Simple classifiers
\begin{code}
isTFunDecl, isDataDecl, isSynDecl, isClassDecl, isKindSigDecl, isIdxTyDecl ::
isDataDecl, isTypeDecl, isSynDecl, isClassDecl, isFamilyDecl, isFamInstDecl ::
TyClDecl name -> Bool
-- type function kind signature
isTFunDecl (TyFunction {}) = True
isTFunDecl other = False
-- vanilla Haskell type synonym
isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
isSynDecl other = False
-- data/newtype or data/newtype instance declaration
isDataDecl (TyData {}) = True
isDataDecl _other = False
-- type equation (of a type function)
isTEqnDecl (TySynonym {tcdTyPats = Just _}) = True
isTEqnDecl other = False
-- type or type instance declaration
isTypeDecl (TySynonym {}) = True
isTypeDecl _other = False
isDataDecl (TyData {}) = True
isDataDecl other = False
-- vanilla Haskell type synonym (ie, not a type instance)
isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
isSynDecl _other = False
-- type class
isClassDecl (ClassDecl {}) = True
isClassDecl other = False
-- kind signature (for an indexed type)
isKindSigDecl (TyFunction {} ) = True
isKindSigDecl (TyData {tcdKindSig = Just _,
tcdCons = [] }) = True
isKindSigDecl other = False
-- definition of an instance of an indexed type
isIdxTyDecl tydecl
| isTEqnDecl tydecl = True
| isDataDecl tydecl = isJust (tcdTyPats tydecl)
| otherwise = False
-- type family declaration
isFamilyDecl (TyFamily {}) = True
isFamilyDecl _other = False
-- family instance (types, newtypes, and data types)
isFamInstDecl tydecl
| isTypeDecl tydecl
|| isDataDecl tydecl = isJust (tcdTyPats tydecl)
| otherwise = False
\end{code}
Dealing with names
......@@ -499,7 +489,7 @@ tyClDeclNames :: Eq name => TyClDecl name -> [Located name]
-- For record fields, the first one counts as the SrcLoc
-- We use the equality to filter out duplicate field names
tyClDeclNames (TyFunction {tcdLName = name}) = [name]
tyClDeclNames (TyFamily {tcdLName = name}) = [name]
tyClDeclNames (TySynonym {tcdLName = name}) = [name]
tyClDeclNames (ForeignType {tcdLName = name}) = [name]
......@@ -510,7 +500,7 @@ tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
= tc_name : conDeclsNames (map unLoc cons)
tyClDeclTyVars (TyFunction {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (TyFamily {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
......@@ -519,21 +509,20 @@ tyClDeclTyVars (ForeignType {}) = []
\begin{code}
countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)
-- class, synonym decls, type function signatures,
-- type function equations, data, newtype
-- class, synonym decls, data, newtype, family decls, family instances
countTyClDecls decls
= (count isClassDecl decls,
count isSynDecl decls,
count isTFunDecl decls,
count isTEqnDecl decls,
count isDataTy decls,
count isNewTy decls)
= (count isClassDecl decls,
count isSynDecl decls, -- excluding...
count isDataTy decls, -- ...family...
count isNewTy decls, -- ...instances
count isFamilyDecl decls,
count isFamInstDecl decls)
where
isDataTy TyData{tcdND=DataType} = True
isDataTy _ = False
isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True
isDataTy _ = False
isNewTy TyData{tcdND=NewType} = True
isNewTy _ = False
isNewTy TyData{tcdND = NewType, tcdTyPats = Nothing} = True
isNewTy _ = False
\end{code}
\begin{code}
......@@ -543,14 +532,18 @@ instance OutputableBndr name
ppr (ForeignType {tcdLName = ltycon})
= hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon]
ppr (TyFunction {tcdLName = ltycon, tcdTyVars = tyvars, tcdIso = iso,
tcdKind = kind})
= typeMaybeIso <+> pp_decl_head [] ltycon tyvars Nothing <+>
dcolon <+> pprKind kind
ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon,
tcdTyVars = tyvars, tcdKind = mb_kind})
= pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
where
typeMaybeIso = if iso
then ptext SLIT("type family iso")
else ptext SLIT("type family")
pp_flavour = case flavour of
TypeFamily -> ptext SLIT("type family")
DataFamily NewType -> ptext SLIT("newtype family")
DataFamily DataType -> ptext SLIT("data family")
pp_kind = case mb_kind of
Nothing -> empty
Just kind -> dcolon <+> pprKind kind
ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
tcdSynRhs = mono_ty})
......
......@@ -38,10 +38,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _ _ _))
("FixityDecls ", fixity_sigs),
("DefaultDecls ", default_ds),
("TypeDecls ", type_ds),
("TypeFunDecls ", type_fun_ds),
("TypeEquations ", type_equs),
("DataDecls ", data_ds),
("NewTypeDecls ", newt_ds),
("TypeFamilyDecls ", type_fam_ds),
("FamilyInstDecls ", fam_inst_ds),
("DataConstrs ", data_constrs),
("DataDerivings ", data_derivs),
("ClassDecls ", class_ds),
......@@ -77,7 +77,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _ _ _))
-- in class decls. ToDo
tycl_decls = [d | TyClD d <- decls]
(class_ds, type_ds, type_fun_ds, type_equs, data_ds, newt_ds) =
(class_ds, type_ds, data_ds, newt_ds, type_fam_ds, fam_inst_ds) =
countTyClDecls tycl_decls
inst_decls = [d | InstD d <- decls]
......
......@@ -422,7 +422,6 @@ data Token
| ITccallconv
| ITdotnet
| ITmdo
| ITiso
| ITfamily
-- Pragmas
......@@ -556,7 +555,6 @@ isSpecial ITunsafe = True
isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
isSpecial ITmdo = True
isSpecial ITiso = True
isSpecial ITfamily = True
isSpecial _ = False
......@@ -649,7 +647,7 @@ reservedSymsFM = listToUFM $
,("∀", ITforall, bit glaExtsBit)
,("→", ITrarrow, bit glaExtsBit)
,("←", ITlarrow, bit glaExtsBit)
,("", ITdotdot, bit glaExtsBit)
,("?", ITdotdot, bit glaExtsBit)
-- ToDo: ideally, → and ∷ should be "specials", so that they cannot
-- form part of a large operator. This would let us have a better
-- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
......
......@@ -44,13 +44,24 @@ import FastString
import Maybes ( orElse )
import Outputable
import Control.Monad ( when )
import Control.Monad ( unless )
import GHC.Exts
import Data.Char
import Control.Monad ( mplus )
}
{-
-----------------------------------------------------------------------------
31 December 2006
Conflicts: 34 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
-----------------------------------------------------------------------------
6 December 2006
......@@ -208,7 +219,6 @@ incorrect.
'threadsafe' { L _ ITthreadsafe }
'unsafe' { L _ ITunsafe }
'mdo' { L _ ITmdo }
'iso' { L _ ITiso }
'family' { L _ ITfamily }
'stdcall' { L _ ITstdcallconv }
'ccall' { L _ ITccallconv }
......@@ -547,7 +557,7 @@ ty_decl :: { LTyClDecl RdrName }
-- infix type constructors to be declared
{% do { (tc, tvs, _) <- checkSynHdr $2 False
; return (L (comb2 $1 $4)
(TySynonym tc tvs Nothing $4))
(TySynonym tc tvs Nothing $4))
} }
-- type family declarations
......@@ -556,11 +566,8 @@ ty_decl :: { LTyClDecl RdrName }
-- infix type constructors to be declared
--
{% do { (tc, tvs, _) <- checkSynHdr $3 False
; let kind = case unLoc $4 of
Nothing -> liftedTypeKind
Just ki -> ki
; return (L (comb3 $1 $3 $4)
(TyFunction tc tvs False kind))
(TyFamily TypeFamily tc tvs (unLoc $4)))
} }
-- type instance declarations
......@@ -598,14 +605,14 @@ ty_decl :: { LTyClDecl RdrName }
-- data/newtype family
| data_or_newtype 'family' tycl_hdr opt_kind_sig
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
; checkTyVars tparms -- no type pattern
; let kind = case unLoc $4 of
Nothing -> liftedTypeKind
Just ki -> ki
; checkTyVars tparms -- no type pattern
; unless (null (unLoc ctxt)) $ -- and no context
parseError (getLoc ctxt)
"A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $4)
(mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing)
(Just kind) [] Nothing) } }
(TyFamily (DataFamily (unLoc $1)) tc tvs
(unLoc $4)) } }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
......@@ -645,11 +652,8 @@ at_decl_cls :: { LTyClDecl RdrName }
-- infix type constructors to be declared
--
{% do { (tc, tvs, _) <- checkSynHdr $2 False
; let kind = case unLoc $3 of
Nothing -> liftedTypeKind
Just ki -> ki
; return (L (comb3 $1 $2 $3)
(TyFunction tc tvs False kind))
(TyFamily TypeFamily tc tvs (unLoc $3)))
} }
-- default type instance
......@@ -665,14 +669,15 @@ at_decl_cls :: { LTyClDecl RdrName }
-- data/newtype family declaration
| data_or_newtype tycl_hdr opt_kind_sig
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
; checkTyVars tparms -- no type pattern
; let kind = case unLoc $3 of
Nothing -> liftedTypeKind
Just ki -> ki
; checkTyVars tparms -- no type pattern
; unless (null (unLoc ctxt)) $ -- and no context
parseError (getLoc ctxt)
"A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $3)
(mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing)
(Just kind) [] Nothing) } }
(TyFamily (DataFamily (unLoc $1)) tc tvs
(unLoc $3))
} }
-- Associate type instances
--
......@@ -709,10 +714,6 @@ at_decl_inst :: { LTyClDecl RdrName }
(mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms)
(unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
opt_iso :: { Bool }
: { False }
| 'iso' { True }
data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
| 'newtype' { L1 NewType }
......@@ -1706,7 +1707,6 @@ varid_no_unsafe :: { Located RdrName }
: VARID { L1 $! mkUnqual varName (getVARID $1) }
| special_id { L1 $! mkUnqual varName (unLoc $1) }
| 'forall' { L1 $! mkUnqual varName FSLIT("forall") }
| 'iso' { L1 $! mkUnqual varName FSLIT("iso") }
| 'family' { L1 $! mkUnqual varName FSLIT("family") }
qvarsym :: { Located RdrName }
......@@ -1731,7 +1731,7 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-'
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
-- except 'unsafe', 'forall', 'family', and 'iso' whose treatment differs
-- except 'unsafe', 'forall', and 'family' whose treatment differs
-- depending on context
special_id :: { Located FastString }
special_id
......
......@@ -311,7 +311,7 @@ add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs, hs_docs = docs})
addl (gp { hs_tyclds = L l d : ts,
hs_fixds = fsigs ++ fs,
hs_docs = add_doc decl docs}) ds
| isIdxTyDecl d =
| isFamInstDecl d =
addl (gp { hs_tyclds = L l d : ts }) ds
| otherwise =
addl (gp { hs_tyclds = L l d : ts,
......@@ -548,7 +548,7 @@ checkKindSigs :: [LTyClDecl RdrName] -> P ()
checkKindSigs = mapM_ check
where
check (L l tydecl)
| isKindSigDecl tydecl
| isFamilyDecl tydecl
|| isSynDecl tydecl = return ()
| otherwise =
parseError l "Type declaration in a class must be a kind signature or synonym default"
......
......@@ -17,7 +17,7 @@ import DynFlags ( DynFlag(..), GhcMode(..), DynFlags(..) )
import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl,
ForeignDecl(..), HsGroup(..), HsValBinds(..),
Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
instDeclATs, isIdxTyDecl,
instDeclATs, isFamInstDecl,
LIE )
import RnEnv
import RnHsDoc ( rnHsDoc )
......@@ -336,7 +336,7 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs,
for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls]
new_tc tc_decl
| isIdxTyDecl (unLoc tc_decl)
| isFamInstDecl (unLoc tc_decl)
= do { main_name <- lookupFamInstDeclBndr mod main_rdr
; sub_names <- mappM (newTopSrcBinder mod) sub_rdrs
; return (AvailTC main_name sub_names) }
......
......@@ -380,26 +380,16 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
Renaming of the associated types in instances.
* We raise an error if we encounter a kind signature in an instance.
\begin{code}
rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
rnATInsts atDecls =
mapFvRn (wrapLocFstM rnATInst) atDecls
where
rnATInst tydecl@TyFunction {} =
do
addErr noKindSig
rnTyClDecl tydecl
rnATInst tydecl@TyData {} = rnTyClDecl tydecl
rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl
rnATInst tydecl@TyData {} =
do
checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig
rnTyClDecl tydecl
rnATInst _ =
panic "RnSource.rnATInsts: not a type declaration"
noKindSig = text "Instances cannot have kind signatures"
rnATInst tydecl =
pprPanic "RnSource.rnATInsts: invalid AT instance"
(ppr (tcdName tydecl))
\end{code}
For the method bindings in class and instance decls, we extend the
......@@ -557,17 +547,21 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_
returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
emptyFVs)
-- all flavours of type family declarations ("type family", "newtype fanily",
-- and "data family")
rnTyClDecl (tydecl@TyFamily {}) =
rnFamily tydecl bindTyVarsRn
-- "data", "newtype", "data instance, and "newtype instance" declarations
rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
tcdLName = tycon, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdCons = condecls,
tcdKindSig = sig, tcdDerivs = derivs})
| isKindSigDecl tydecl -- kind signature of indexed type
= rnTySig tydecl bindTyVarsRn
| 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' <- if isIdxTyDecl tydecl
do { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
; context' <- rnContext data_doc context
......@@ -583,14 +577,14 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
extractHsCtxtTyNames context' `plusFV`
plusFVs (map conDeclFVs condecls') `plusFV`
deriv_fvs `plusFV`
(if isIdxTyDecl tydecl
(if isFamInstDecl tydecl
then unitFV (unLoc tycon') -- type instance => use
else emptyFVs))
}
| otherwise -- GADT
= ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now
do { tycon' <- if isIdxTyDecl tydecl
do { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
......@@ -608,7 +602,7 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
tcdCons = condecls', tcdDerivs = derivs'},
plusFVs (map conDeclFVs condecls') `plusFV`
deriv_fvs `plusFV`
(if isIdxTyDecl tydecl
(if isFamInstDecl tydecl
then unitFV (unLoc tycon') -- type instance => use
else emptyFVs))
}
......@@ -631,13 +625,11 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
returnM (Just ds', extractHsTyNames_s ds')
rnTyClDecl (tydecl@TyFunction {}) =
rnTySig tydecl bindTyVarsRn
-- "type" and "type instance" declarations
rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdSynRhs = ty})
= bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
do { name' <- if isIdxTyDecl tydecl
do { name' <- if isFamInstDecl tydecl
then lookupLocatedOccRn name -- may be imported family
else lookupLocatedTopBndrRn name
; typats' <- rnTyPats syn_doc typatsMaybe
......@@ -646,7 +638,7 @@ rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
tcdTyPats = typats', tcdSynRhs = ty'},
delFVs (map hsLTyVarName tyvars') $
fvs `plusFV`
(if isIdxTyDecl tydecl
(if isFamInstDecl tydecl
then unitFV (unLoc name') -- type instance => use
else emptyFVs))
}
......@@ -808,64 +800,45 @@ rnField doc (HsRecField name ty haddock_doc)
rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc ->
returnM (HsRecField new_name new_ty new_haddock_doc)
-- Rename kind signatures (signatures of indexed data types/newtypes and
-- signatures of type functions)
-- Rename family declarations
--
-- * This function is parametrised by the routine handling the index
-- variables. On the toplevel, these are defining occurences, whereas they
-- are usage occurences for associated types.
--
rnTySig :: TyClDecl RdrName
-> (SDoc -> [LHsTyVarBndr RdrName] ->
([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
RnM (TyClDecl Name, FreeVars))
-> RnM (TyClDecl Name, FreeVars)
rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon,
tcdTyVars = tyvars, tcdTyPats = mb_typats,
tcdCons = condecls, tcdKindSig = sig,
tcdDerivs = derivs})
rnFamily :: TyClDecl RdrName
-> (SDoc -> [LHsTyVarBndr RdrName] ->
([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
RnM (TyClDecl Name, FreeVars))
-> RnM (TyClDecl Name, FreeVars)
rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
tcdLName = tycon, tcdTyVars = tyvars})
bindIdxVars =
ASSERT( null condecls ) -- won't have constructors
ASSERT( isNothing mb_typats ) -- won't have type patterns
ASSERT( isNothing derivs ) -- won't have deriving
ASSERT( isJust sig ) -- will have kind signature
do { bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
do { checkM (isDataFlavour flavour -- for synonyms,
|| not (null tyvars)) $ addErr needOneIdx -- #indexes >= 1
; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
; tycon' <- lookupLocatedTopBndrRn tycon
; context' <- rnContext (ksig_doc tycon) context
; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context',
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = Nothing, tcdKindSig = sig,
tcdCons = [], tcdDerivs = Nothing},
delFVs (map hsLTyVarName tyvars') $
extractHsCtxtTyNames context')
} }
where
rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
tcdKind = sig})
bindIdxVars =
do { checkM (not . null $ tyvars) $ addErr needOneIdx -- #indexes >= 1
; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
; tycon' <- lookupLocatedTopBndrRn tycon
; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
tcdIso = tcdIso tydecl, tcdKind = sig},
; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
emptyFVs)
} }
where
isDataFlavour (DataFamily _) = True
isDataFlavour _ = False
ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
needOneIdx = text "Kind signature requires at least one type index"
family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
needOneIdx = text "Type family declarations requires at least one type index"
-- Rename associated type declarations (in classes)
--
-- * This can be kind signatures and (default) type function equations.
-- * This can be family declarations and (default) type instances
--
rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
where
rn_at (tydecl@TyData {}) = rnTySig tydecl lookupIdxVars
rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars
rn_at (tydecl@TySynonym {}) =
rn_at (tydecl@TyFamily {}) = rnFamily tydecl lookupIdxVars
rn_at (tydecl@TySynonym {}) =
do
checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
rnTyClDecl tydecl
......
......@@ -727,15 +727,15 @@ mkGenericInstance clas (hs_ty, binds)
tcAddDeclCtxt decl thing_inside
= addErrCtxt ctxt thing_inside
where
thing = case decl of
ClassDecl {} -> "class"
TySynonym {} -> "type synonym"
TyFunction {} -> "type function signature"
TyData {tcdND = NewType} -> "newtype" ++ maybeSig
TyData {tcdND = DataType} -> "data type" ++ maybeSig
maybeSig | isKindSigDecl decl = " signature"
| otherwise = ""
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"
maybeInst | isFamInstDecl decl = " family"
| otherwise = ""
ctxt = hsep [ptext SLIT("In the"), text thing,
ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
......
......@@ -147,9 +147,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- (they recover, so that we get more than one error each
-- round)
-- (1) Do class instance declarations and instances of indexed
-- types
; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
-- (1) Do class and family instance declarations
; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
; idx_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
......@@ -193,7 +192,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- !!!TODO: Need to perform this check for the TyThing of type functions,
-- too.
tcIdxTyInstDeclTL ldecl@(L loc decl) =
do { tything <- tcIdxTyInstDecl ldecl
do { tything <- tcFamInstDecl ldecl
; setSrcSpan loc $
when (isAssocFamily tything) $
addErr $ assocInClassErr (tcdName decl)
......@@ -243,7 +242,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
; (tyvars, theta, tau) <- tcHsInstHead poly_ty
-- Next, process any associated types.
; idx_tycons <- mappM tcIdxTyInstDecl ats
; idx_tycons <- mappM tcFamInstDecl ats
-- Now, check the validity of the instance.
; (clas, inst_tys) <- checkValidInstHead tau
......
This diff is collapsed.
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