X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsDecls.lhs;h=f1cde04ee492ab90a364a867558085e12c814ac5;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hp=b1c64efc6fea2f2a05f3e005391585fe9efc8b18;hpb=d34ff7ff372ae76874bb1409f13579ef60076771;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index b1c64ef..f1cde04 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -9,6 +9,13 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@, @InstDecl@, @DefaultDecl@ and @ForeignDecl@. \begin{code} +{-# OPTIONS_GHC -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- for details + module HsDecls ( HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl, InstDecl(..), LInstDecl, DerivDecl(..), LDerivDecl, NewOrData(..), @@ -17,7 +24,8 @@ module HsDecls ( DefaultDecl(..), LDefaultDecl, SpliceDecl(..), ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), CImportSpec(..), FoType(..), - ConDecl(..), ResType(..), LConDecl, + ConDecl(..), ResType(..), ConDeclField(..), LConDecl, + HsConDeclDetails, hsConDeclArgTys, DocDecl(..), LDocDecl, docDeclDoc, DeprecDecl(..), LDeprecDecl, HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, @@ -25,7 +33,6 @@ module HsDecls ( isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl, isFamInstDecl, countTyClDecls, - conDetailsTys, instDeclATs, collectRuleBndrSigTys, ) where @@ -358,7 +365,7 @@ Interface file code: -- -- * 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'. -- @@ -399,8 +406,10 @@ data TyClDecl name -- instance' decl with explicit kind sig tcdCons :: [LConDecl name], -- Data constructors - -- For data T a = T1 | T2 a the LConDecls all have ResTyH98 - -- For data T a where { T1 :: T a } the LConDecls all have ResTyGADT + -- For data T a = T1 | T2 a + -- the LConDecls all have ResTyH98 + -- For data T a where { T1 :: T a } + -- the LConDecls all have ResTyGADT tcdDerivs :: Maybe [LHsType name] -- Derivings; Nothing => not specified @@ -427,9 +436,9 @@ data TyClDecl name tcdSigs :: [LSig name], -- Methods' signatures tcdMeths :: LHsBinds name, -- Default methods tcdATs :: [LTyClDecl name], -- Associated types; ie - -- only 'TyData', - -- 'TyFunction', - -- and 'TySynonym' + -- only 'TyFamily' and + -- 'TySynonym'; the + -- latter for defaults tcdDocs :: [LDocDecl name] -- Haddock docs } @@ -440,7 +449,7 @@ data NewOrData data FamilyFlavour = TypeFamily -- "type family ..." - | DataFamily NewOrData -- "newtype family ..." or "data family ..." + | DataFamily -- "data family ..." \end{code} Simple classifiers @@ -536,9 +545,8 @@ instance OutputableBndr name = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind where pp_flavour = case flavour of - TypeFamily -> ptext SLIT("type family") - DataFamily NewType -> ptext SLIT("newtype family") - DataFamily DataType -> ptext SLIT("data family") + TypeFamily -> ptext SLIT("type family") + DataFamily -> ptext SLIT("data family") pp_kind = case mb_kind of Nothing -> empty @@ -651,13 +659,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, @@ -665,7 +685,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 @@ -673,14 +693,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} @@ -688,6 +707,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 @@ -704,7 +724,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} %************************************************************************ @@ -849,11 +873,11 @@ data FoType = DNType -- In due course we'll add subtype stuff instance OutputableBndr name => Outputable (ForeignDecl name) where ppr (ForeignImport n ty fimport) = - ptext SLIT("foreign import") <+> ppr fimport <+> - ppr n <+> dcolon <+> ppr ty + hang (ptext SLIT("foreign import") <+> ppr fimport <+> ppr n) + 2 (dcolon <+> ppr ty) ppr (ForeignExport n ty fexport) = - ptext SLIT("foreign export") <+> ppr fexport <+> - ppr n <+> dcolon <+> ppr ty + hang (ptext SLIT("foreign export") <+> ppr fexport <+> ppr n) + 2 (dcolon <+> ppr ty) instance Outputable ForeignImport where ppr (DNImport spec) =