From: Manuel M T Chakravarty Date: Fri, 5 Jan 2007 01:26:19 +0000 (+0000) Subject: HsSyn clean up for indexed types X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=e3dd39bf230380f02d73efc287226117bb2eb47f 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 --- diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 09d8d0a..2b97668 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -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}) diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index ee8717f..0327cce 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -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] diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index bb0fc1e..49dabf0 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -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). diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 060eeac..55f8cf2 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -44,7 +44,7 @@ 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 ) @@ -52,6 +52,17 @@ 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 Conflicts: 32 shift/reduce @@ -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 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 200ea57..687ffd2 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -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" diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 05cfa96..ccdf18b 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -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) } diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 9653bdc..a9d6c5d 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -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 diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 92c7958..f43a4d7 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -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))] diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index da18ef1..b4d3498 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -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 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 834bedc..4d0030e 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -7,7 +7,7 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} module TcTyClsDecls ( - tcTyAndClassDecls, tcIdxTyInstDecl + tcTyAndClassDecls, tcFamInstDecl ) where #include "HsVersions.h" @@ -45,6 +45,7 @@ import Digraph import DynFlags import Data.List ( partition, elemIndex ) +import Control.Monad ( mplus ) \end{code} @@ -134,7 +135,7 @@ tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] tcTyAndClassDecls boot_details allDecls = do { -- Omit instances of indexed types; they are handled together -- with the *heads* of class instances - ; let decls = filter (not . isIdxTyDecl . unLoc) allDecls + ; let decls = filter (not . isFamInstDecl . unLoc) allDecls -- First check for cyclic type synonysm or classes -- See notes with checkCycleErrs @@ -222,36 +223,36 @@ mkGlobalThings decls things %************************************************************************ %* * -\subsection{Type checking instances of indexed types} +\subsection{Type checking family instances} %* * %************************************************************************ -Instances of indexed types are somewhat of a hybrid. They are processed -together with class instance heads, but can contain data constructors and hence -they share a lot of kinding and type checking code with ordinary algebraic -data types (and GADTs). +Family instances are somewhat of a hybrid. They are processed together with +class instance heads, but can contain data constructors and hence they share a +lot of kinding and type checking code with ordinary algebraic data types (and +GADTs). \begin{code} -tcIdxTyInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error -tcIdxTyInstDecl (L loc decl) +tcFamInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error +tcFamInstDecl (L loc decl) = -- Prime error recovery, set source location recoverM (returnM Nothing) $ setSrcSpan loc $ tcAddDeclCtxt decl $ - do { -- indexed data types require -findexed-types and can't be in an + do { -- type families require -findexed-types and can't be in an -- hs-boot file ; gla_exts <- doptM Opt_IndexedTypes ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc gla_exts $ badIdxTyDecl (tcdLName decl) - ; checkTc (not is_boot) $ badBootTyIdxDeclErr + ; checkTc gla_exts $ badFamInstDecl (tcdLName decl) + ; checkTc (not is_boot) $ badBootFamInstDeclErr -- perform kind and type checking - ; tcIdxTyInstDecl1 decl + ; tcFamInstDecl1 decl } -tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error +tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error -tcIdxTyInstDecl1 (decl@TySynonym {}) +tcFamInstDecl1 (decl@TySynonym {}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> do { -- check that the family declaration is for a synonym unless (isSynTyCon family) $ @@ -269,8 +270,8 @@ tcIdxTyInstDecl1 (decl@TySynonym {}) ; return Nothing -- !!!TODO: need TyThing for indexed synonym }} -tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, - tcdCons = cons}) +tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, + tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> do { -- check that the family declaration is for the right kind unless (new_or_data == NewType && isNewTyCon family || @@ -391,11 +392,11 @@ Indexed Types This treatment of type synonyms only applies to Haskell 98-style synonyms. General type functions can be recursive, and hence, appear in `alg_decls'. -The kind of an indexed type is solely determinded by its kind signature; +The kind of a type family is solely determinded by its kind signature; hence, only kind signatures participate in the construction of the initial kind environment (as constructed by `getInitialKind'). In fact, we ignore -instances of indexed types altogether in the following. However, we need to -include the kind signatures of associated types into the construction of the +instances of families altogether in the following. However, we need to +include the kinds of associated families into the construction of the initial kind environment. (This is handled by `allDecls'). \begin{code} @@ -420,7 +421,7 @@ kcTyClDecls syn_decls alg_decls -- instances of indexed types yet, but leave this to -- `tcInstDecls1' { kc_alg_decls <- mappM (wrapLocM kcTyClDecl) - (filter (not . isIdxTyDecl . unLoc) alg_decls) + (filter (not . isFamInstDecl . unLoc) alg_decls) ; return (kc_syn_decls, kc_alg_decls) }}} where @@ -428,9 +429,9 @@ kcTyClDecls syn_decls alg_decls -- environment allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at | L _ at <- ats - , isKindSigDecl at] - allDecls decl | isIdxTyDecl decl = [] - | otherwise = [decl] + , isFamilyDecl at] + allDecls decl | isFamInstDecl decl = [] + | otherwise = [decl] ------------------------------------------------------------------------ getInitialKind :: TyClDecl Name -> TcM (Name, TcKind) @@ -445,10 +446,9 @@ getInitialKind decl mk_arg_kind (UserTyVar _) = newKindVar mk_arg_kind (KindedTyVar _ kind) = return kind - mk_res_kind (TyFunction { tcdKind = kind }) = return kind - mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind - -- On GADT-style and data signature declarations we allow a kind - -- signature + mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind + mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind + -- On GADT-style declarations we allow a kind signature -- data T :: *->* where { ... } mk_res_kind other = return liftedTypeKind @@ -490,13 +490,15 @@ kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) -- Not used for type synonyms (see kcSynDecl) kcTyClDecl decl@(TyData {}) - = ASSERT( not . isJust $ tcdTyPats decl ) -- must not be instance of idx ty + = ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance kcTyClDeclBody decl $ kcDataDecl decl -kcTyClDecl decl@(TyFunction {}) +kcTyClDecl decl@(TyFamily {tcdKind = kind}) = kcTyClDeclBody decl $ \ tvs' -> - return (decl {tcdTyVars = tvs'}) + return (decl {tcdTyVars = tvs', + tcdKind = kind `mplus` Just liftedTypeKind}) + -- default result kind is '*' kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) = kcTyClDeclBody decl $ \ tvs' -> @@ -599,33 +601,36 @@ tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] tcTyClDecl calc_isrec decl = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) - -- kind signature for a type function + -- "type family" declarations tcTyClDecl1 _calc_isrec - (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind}) + (TyFamily {tcdFlavour = TypeFamily, + tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = Just kind}) + -- NB: kind at latest + -- added during + -- kind checking = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "type family: " <+> ppr tc_name) - ; gla_exts <- doptM Opt_IndexedTypes + ; idx_tys <- doptM Opt_IndexedTypes - -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc gla_exts $ badSigTyDecl tc_name + -- Check that we don't use families without -findexed-types + ; checkTc idx_tys $ badFamInstDecl tc_name ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)] } - -- kind signature for an indexed data type + -- "newtype family" or "data family" declaration tcTyClDecl1 _calc_isrec - (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, - tcdLName = L _ tc_name, tcdKindSig = Just ksig, tcdCons = []}) + (TyFamily {tcdFlavour = DataFamily new_or_data, + tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind}) = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "data/newtype family: " <+> ppr tc_name) - ; extra_tvs <- tcDataKindSig (Just ksig) + ; extra_tvs <- tcDataKindSig mb_kind ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name - ; gla_exts <- doptM Opt_IndexedTypes + ; idx_tys <- doptM Opt_IndexedTypes - -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc gla_exts $ badSigTyDecl tc_name + -- Check that we don't use families without -findexed-types + ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] (case new_or_data of @@ -635,6 +640,7 @@ tcTyClDecl1 _calc_isrec ; return [ATyCon tycon] } + -- "newtype", "data", "newtype instance", "data instance" tcTyClDecl1 calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) @@ -1156,36 +1162,31 @@ newtypeFieldErr con_name n_flds badSigTyDecl tc_name = vcat [ ptext SLIT("Illegal kind signature") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -findexed-types to allow indexed types")) ] - -badKindSigCtxt tc_name - = vcat [ ptext SLIT("Illegal context in kind signature") <+> - quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Currently, kind signatures cannot have a context")) ] + , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow kind signatures")) ] -badIdxTyDecl tc_name - = vcat [ ptext SLIT("Illegal indexed type instance for") <+> +badFamInstDecl tc_name + = vcat [ ptext SLIT("Illegal family instance for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -findexed-types to allow indexed types")) ] + , nest 2 (parens $ ptext SLIT("Use -findexed-types to allow indexed type families")) ] badGadtIdxTyDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Indexed types cannot use GADT declarations")) ] + , nest 2 (parens $ ptext SLIT("Family instances can not yet use GADT declarations")) ] tooManyParmsErr tc_name - = ptext SLIT("Indexed type instance has too many parameters:") <+> + = ptext SLIT("Family instance has too many parameters:") <+> quotes (ppr tc_name) tooFewParmsErr tc_name - = ptext SLIT("Indexed type instance has too few parameters:") <+> + = ptext SLIT("Family instance has too few parameters:") <+> quotes (ppr tc_name) -badBootTyIdxDeclErr = - ptext SLIT("Illegal indexed type instance in hs-boot file") +badBootFamInstDeclErr = + ptext SLIT("Illegal family instance in hs-boot file") wrongKindOfFamily family = - ptext SLIT("Wrong category of type instance; declaration was for a") <+> + ptext SLIT("Wrong category of family instance; declaration was for a") <+> kindOfFamily where kindOfFamily | isSynTyCon family = ptext SLIT("type synonym")