X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsDecls.lhs;h=4f0fc03ff2e621ed6f4640fa0156222af1310f9a;hb=418175d3c36ca51495d9dfb085fb01711e4c38f9;hp=733a8ea8be3b6d710c097dcec60227d5f42396e2;hpb=190f24892156953d73b55401d0467a6f1a88ce5d;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 733a8ea..4f0fc03 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[HsDecls]{Abstract syntax: global declarations} + +HsDecls: Abstract syntax: global declarations Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@, @InstDecl@, @DefaultDecl@ and @ForeignDecl@. @@ -10,19 +12,20 @@ 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(..), CImportSpec(..), FoType(..), - ConDecl(..), ResType(..), LConDecl, - DocDecl(..), LDocDecl, docDeclDoc, DocEntity(..), + ConDecl(..), ResType(..), ConDeclField(..), LConDecl, + HsConDeclDetails, hsConDeclArgTys, + DocDecl(..), LDocDecl, docDeclDoc, DeprecDecl(..), LDeprecDecl, HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, tcdName, tyClDeclNames, tyClDeclTyVars, - isClassDecl, isTFunDecl, isSynDecl, isDataDecl, isKindSigDecl, - isIdxTyDecl, + isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl, + isFamInstDecl, countTyClDecls, - conDetailsTys, instDeclATs, collectRuleBndrSigTys, ) where @@ -33,27 +36,25 @@ module HsDecls ( import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) -- Because Expr imports Decls via HsBracket -import HsBinds ( HsValBinds(..), HsBind, LHsBinds, plusHsValBinds, - Sig(..), LSig, LFixitySig, pprLHsBinds, - emptyValBindsIn, emptyValBindsOut ) -import HsPat ( HsConDetails(..), hsConArgs, HsRecField(..) ) -import HsImpExp ( pprHsVar ) +import HsBinds +import HsPat +import HsImpExp import HsTypes -import HsDoc ( HsDoc, LHsDoc, ppr_mbDoc ) -import NameSet ( NameSet ) -import CoreSyn ( RuleName ) -import {- Kind parts of -} Type ( Kind, pprKind ) -import BasicTypes ( Activation(..), DeprecTxt ) -import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety, - CExportSpec(..), CLabelString ) +import HsDoc +import NameSet +import CoreSyn +import {- Kind parts of -} Type +import BasicTypes +import ForeignCall -- others: -import Class ( FunDep, pprFundeps ) +import Class import Outputable -import Util ( count ) -import SrcLoc ( Located(..), unLoc, noLoc ) +import Util +import SrcLoc import FastString -import Maybe ( isJust ) + +import Data.Maybe ( isJust ) \end{code} %************************************************************************ @@ -110,9 +111,7 @@ data HsGroup id hs_depds :: [LDeprecDecl id], hs_ruleds :: [LRuleDecl id], - hs_docs :: [DocEntity id] - -- Used to remember the module structure, - -- which is needed to produce Haddock documentation + hs_docs :: [LDocDecl id] } emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a @@ -344,20 +343,11 @@ Interface file code: \begin{code} --- TyClDecls are precisely the kind of declarations that can --- appear in interface files; or (internally) in GHC's interface --- for a module. That's why (despite the misnomer) IfaceSig and ForeignType --- are both in TyClDecl - -- 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: @@ -366,9 +356,9 @@ 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 +-- and 'tcdTyVars' are the variables in those patterns. Hence, the arity of -- the indexed type (ie, the number of indexes) is 'length tcdTyPats' and -- *not* 'length tcdVars'. -- @@ -381,17 +371,32 @@ data TyClDecl name tcdLName :: Located name, tcdExtName :: Maybe FastString, tcdFoType :: FoType - } + } + -- type/data/newtype family T :: *->* + | TyFamily { tcdFlavour:: FamilyFlavour, -- type, new, or data + tcdLName :: Located name, -- type constructor + tcdTyVars :: [LHsTyVarBndr name], -- type variables + tcdKind :: Maybe Kind -- result kind + } + + -- Declares a data type or newtype, giving its construcors + -- data/newtype T a = + -- data/newtype instance T [a] = | TyData { tcdND :: NewOrData, tcdCtxt :: LHsContext name, -- Context tcdLName :: Located name, -- Type constructor + tcdTyVars :: [LHsTyVarBndr name], -- Type variables + tcdTyPats :: Maybe [LHsType name], -- Type patterns - tcdKindSig:: Maybe Kind, -- Optional kind sig; - -- (only for the - -- 'where' form and - -- indexed type sigs) + -- Just [t1..tn] for data instance T t1..tn = ... + -- in this case tcdTyVars = fv( tcdTyPats ) + -- Nothing for everything else + + tcdKindSig:: Maybe Kind, -- Optional kind sig + -- (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 @@ -406,17 +411,12 @@ data TyClDecl name -- are non-empty for the newtype-deriving case } - | 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 tcdTyPats :: Maybe [LHsType name], -- Type patterns - -- 'Nothing' => vanilla - -- type synonym + -- See comments for tcdTyPats in TyData + -- 'Nothing' => vanilla type synonym + tcdSynRhs :: LHsType name -- synonym expansion } @@ -430,50 +430,50 @@ data TyClDecl name -- only 'TyData', -- 'TyFunction', -- and 'TySynonym' - tcdDocs :: [DocEntity name] -- Haddock docs + tcdDocs :: [LDocDecl name] -- Haddock docs } 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 -- "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 @@ -488,7 +488,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] @@ -499,7 +499,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 @@ -508,21 +508,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} @@ -532,14 +531,17 @@ 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 -> 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}) @@ -648,13 +650,25 @@ data ConDecl name , con_cxt :: LHsContext name -- The context. This *does not* include the -- "stupid theta" which lives only in the TyData decl - , con_details :: HsConDetails name (LBangType name) -- The main payload + , con_details :: HsConDeclDetails name -- The main payload , con_res :: ResType name -- Result type of the constructor , con_doc :: Maybe (LHsDoc name) -- A possible Haddock comment } +type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name] + +hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name] +hsConDeclArgTys (PrefixCon tys) = tys +hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] +hsConDeclArgTys (RecCon flds) = map cd_fld_type flds + +data ConDeclField name -- Record fields have Haddoc docs on them + = ConDeclField { cd_fld_name :: Located name, + cd_fld_type :: LBangType name, + cd_fld_doc :: Maybe (LHsDoc name) } + data ResType name = ResTyH98 -- Constructor was declared using Haskell 98 syntax | ResTyGADT (LHsType name) -- Constructor was declared using GADT-style syntax, @@ -662,7 +676,7 @@ data ResType name \end{code} \begin{code} -conDeclsNames :: Eq name => [ConDecl name] -> [Located name] +conDeclsNames :: forall name. Eq name => [ConDecl name] -> [Located name] -- See tyClDeclNames for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful @@ -670,14 +684,13 @@ conDeclsNames cons = snd (foldl do_one ([], []) cons) where do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds }) - = (map unLoc new_flds ++ flds_seen, lname : [f | f <- new_flds] ++ acc) + = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc) where - new_flds = [ f | (HsRecField f _ _) <- flds, not (unLoc f `elem` flds_seen) ] + new_flds = filterOut (\f -> unLoc f `elem` flds_seen) + (map cd_fld_name flds) do_one (flds_seen, acc) c = (flds_seen, (con_name c):acc) - -conDetailsTys details = map getBangType (hsConArgs details) \end{code} @@ -685,6 +698,7 @@ conDetailsTys details = map getBangType (hsConArgs details) instance (OutputableBndr name) => Outputable (ConDecl name) where ppr = pprConDecl +pprConDecl :: OutputableBndr name => ConDecl name -> SDoc pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc) = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details] where @@ -701,7 +715,11 @@ pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty) _) pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _) = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_fields fields <+> dcolon <+> ppr res_ty] -ppr_fields fields = braces (sep (punctuate comma (map ppr fields))) +ppr_fields fields = braces (sep (punctuate comma (map ppr_fld fields))) + where + ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, + cd_fld_doc = doc }) + = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc \end{code} %************************************************************************ @@ -745,12 +763,11 @@ instDeclATs (InstDecl _ _ _ ats) = ats \begin{code} type LDerivDecl name = Located (DerivDecl name) -data DerivDecl name - = DerivDecl (LHsType name) (Located name) +data DerivDecl name = DerivDecl (LHsType name) instance (OutputableBndr name) => Outputable (DerivDecl name) where - ppr (DerivDecl ty n) - = hsep [ptext SLIT("deriving"), ppr ty, ptext SLIT("for"), ppr n] + ppr (DerivDecl ty) + = hsep [ptext SLIT("derived instance"), ppr ty] \end{code} %************************************************************************ @@ -932,11 +949,6 @@ instance OutputableBndr name => Outputable (RuleBndr name) where \begin{code} --- source code entities, for representing the module structure -data DocEntity name - = DeclEntity name - | DocEntity (DocDecl name) - type LDocDecl name = Located (DocDecl name) data DocDecl name