X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=f1343a39ef9aa5e7621b1eb176a34b8751afedc9;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=6d8013ccf7f7378c7a34fc6f591f9fae5d5eacbd;hpb=98643c2d5bd08ec71edd555e8989e530de6f5921;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 6d8013c..f1343a3 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -1,37 +1,41 @@ -]% +% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[HsTypes]{Abstract syntax: user-defined types} \begin{code} module HsTypes ( - HsType(..), HsTyVarBndr(..), - , HsContext, HsPred(..) - - , mkHsForAllTy, mkHsDictTy, mkHsIParamTy - , hsTyVarName, hsTyVarNames, replaceTyVarName - , splitHsInstDeclTy + HsType(..), LHsType, + HsTyVarBndr(..), LHsTyVarBndr, + HsExplicitForAll(..), + HsContext, LHsContext, + HsPred(..), LHsPred, + + LBangType, BangType, HsBang(..), + getBangType, getBangStrictness, + + mkExplicitHsForAllTy, mkImplicitHsForAllTy, + hsTyVarName, hsTyVarNames, replaceTyVarName, + hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, + splitHsInstDeclTy, splitHsFunType, -- Type place holder - , PostTcType, placeHolderType, - - -- Name place holder - , SyntaxName, placeHolderName, + PostTcType, placeHolderType, -- Printing - , pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr + pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr ) where #include "HsVersions.h" -import TcType ( Type, Kind, liftedTypeKind, eqKind ) -import TypeRep ( Type ) -import Name ( Name, mkInternalName ) -import OccName ( mkVarOcc ) -import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind ) +import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) + +import Type ( Type ) +import Kind ( {- instance Outputable Kind -}, Kind, + pprParendKind, pprKind, isLiftedTypeKind ) import BasicTypes ( IPName, Boxity, tupleParens ) -import PrelNames ( unboundKey ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( Located(..), unLoc, noSrcSpan ) +import StaticFlags ( opt_PprStyle_Debug ) import Outputable \end{code} @@ -50,18 +54,35 @@ type PostTcType = Type -- Used for slots in the abstract syntax placeHolderType :: PostTcType -- Used before typechecking placeHolderType = panic "Evaluated the place holder for a PostTcType" +\end{code} +%************************************************************************ +%* * +\subsection{Bang annotations} +%* * +%************************************************************************ -type SyntaxName = Name -- These names are filled in by the renamer - -- Before then they are a placeHolderName (so that - -- we can still print the HsSyn) - -- They correspond to "rebindable syntax"; - -- See RnEnv.lookupSyntaxName - -placeHolderName :: SyntaxName -placeHolderName = mkInternalName unboundKey - (mkVarOcc FSLIT("syntaxPlaceHolder")) - noSrcLoc +\begin{code} +type LBangType name = Located (BangType name) +type BangType name = HsType name -- Bangs are in the HsType data type + +data HsBang = HsNoBang -- Only used as a return value for getBangStrictness, + -- never appears on a HsBangTy + | HsStrict -- ! + | HsUnbox -- {-# UNPACK #-} ! (GHC extension, meaning "unbox") + +instance Outputable HsBang where + ppr (HsNoBang) = empty + ppr (HsStrict) = char '!' + ppr (HsUnbox) = ptext SLIT("!!") + +getBangType :: LHsType a -> LHsType a +getBangType (L _ (HsBangTy _ ty)) = ty +getBangType ty = ty + +getBangStrictness :: LHsType a -> HsBang +getBangStrictness (L _ (HsBangTy s _)) = s +getBangStrictness _ = HsNoBang \end{code} @@ -74,34 +95,46 @@ placeHolderName = mkInternalName unboundKey This is the syntax for types as seen in type signatures. \begin{code} -type HsContext name = [HsPred name] +type LHsContext name = Located (HsContext name) + +type HsContext name = [LHsPred name] + +type LHsPred name = Located (HsPred name) + +data HsPred name = HsClassP name [LHsType name] + | HsIParam (IPName name) (LHsType name) -data HsPred name = HsClassP name [HsType name] - | HsIParam (IPName name) (HsType name) +type LHsType name = Located (HsType name) data HsType name - = HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures - (HsContext name) - (HsType name) + = HsForAllTy HsExplicitForAll -- Renamer leaves this flag unchanged, to record the way + -- the user wrote it originally, so that the printer can + -- print it as the user wrote it + [LHsTyVarBndr name] -- With ImplicitForAll, this is the empty list + -- until the renamer fills in the variables + (LHsContext name) + (LHsType name) | HsTyVar name -- Type variable or type constructor - | HsAppTy (HsType name) - (HsType name) + | HsBangTy HsBang (LHsType name) -- Bang-style type annotations - | HsFunTy (HsType name) -- function type - (HsType name) + | HsAppTy (LHsType name) + (LHsType name) - | HsListTy (HsType name) -- Element type + | HsFunTy (LHsType name) -- function type + (LHsType name) - | HsPArrTy (HsType name) -- Elem. type of parallel array: [:t:] + | HsListTy (LHsType name) -- Element type + + | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] | HsTupleTy Boxity - [HsType name] -- Element types (length gives arity) + [LHsType name] -- Element types (length gives arity) - | HsOpTy (HsType name) name (HsType name) + | HsOpTy (LHsType name) (Located name) (LHsType name) - | HsParTy (HsType name) + | HsParTy (LHsType name) -- Parenthesis preserved for the precedence re-arrangement in RnTypes -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! -- @@ -111,12 +144,19 @@ data HsType name | HsNumTy Integer -- Generics only - -- these next two are only used in interfaces - | HsPredTy (HsPred name) + | HsPredTy (HsPred name) -- Only used in the type of an instance + -- declaration, eg. Eq [a] -> Eq a + -- ^^^^ + -- HsPredTy + -- Note no need for location info on the + -- enclosed HsPred; the one on the type will do - | HsKindSig (HsType name) -- (ty :: kind) + | HsKindSig (LHsType name) -- (ty :: kind) Kind -- A type with a kind signature + | HsSpliceTy (HsSplice name) + +data HsExplicitForAll = Explicit | Implicit ----------------------- -- Combine adjacent for-alls. @@ -128,34 +168,55 @@ data HsType name -- -- A valid type must have one for-all at the top of the type, or of the fn arg types -mkHsForAllTy mtvs [] ty = mk_forall_ty mtvs ty -mkHsForAllTy mtvs ctxt ty = HsForAllTy mtvs ctxt ty +mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty +mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty + +mkHsForAllTy :: HsExplicitForAll -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name +-- Smart constructor for HsForAllTy +mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty +mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty -- mk_forall_ty makes a pure for-all type (no context) -mk_forall_ty (Just []) ty = ty -- Explicit for-all with no tyvars -mk_forall_ty mtvs1 (HsParTy ty) = mk_forall_ty mtvs1 ty -mk_forall_ty mtvs1 (HsForAllTy mtvs2 ctxt ty) = mkHsForAllTy (mtvs1 `plus` mtvs2) ctxt ty -mk_forall_ty mtvs1 ty = HsForAllTy mtvs1 [] ty +mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty +mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty +mk_forall_ty exp tvs ty = HsForAllTy exp tvs (L noSrcSpan []) ty + -- Even if tvs is empty, we still make a HsForAll! + -- In the Implicit case, this signals the place to do implicit quantification + -- In the Explicit case, it prevents implicit quantification + -- (see the sigtype production in Parser.y.pp) + -- so that (forall. ty) isn't implicitly quantified -mtvs1 `plus` Nothing = mtvs1 -Nothing `plus` mtvs2 = mtvs2 -(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2) +Implicit `plus` Implicit = Implicit +exp1 `plus` exp2 = Explicit -mkHsDictTy cls tys = HsPredTy (HsClassP cls tys) -mkHsIParamTy v ty = HsPredTy (HsIParam v ty) +type LHsTyVarBndr name = Located (HsTyVarBndr name) data HsTyVarBndr name = UserTyVar name | KindedTyVar name Kind - -- *** NOTA BENE *** A "monotype" in a pragma can have + -- *** NOTA BENE *** A "monotype" in a pragma can have -- for-alls in it, (mostly to do with dictionaries). These -- must be explicitly Kinded. +hsTyVarName :: HsTyVarBndr name -> name hsTyVarName (UserTyVar n) = n hsTyVarName (KindedTyVar n _) = n +hsLTyVarName :: LHsTyVarBndr name -> name +hsLTyVarName = hsTyVarName . unLoc + +hsTyVarNames :: [HsTyVarBndr name] -> [name] hsTyVarNames tvs = map hsTyVarName tvs +hsLTyVarNames :: [LHsTyVarBndr name] -> [name] +hsLTyVarNames = map hsLTyVarName + +hsLTyVarLocName :: LHsTyVarBndr name -> Located name +hsLTyVarLocName = fmap hsTyVarName + +hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name] +hsLTyVarLocNames = map hsLTyVarLocName + replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2 replaceTyVarName (UserTyVar n) n' = UserTyVar n' replaceTyVarName (KindedTyVar n k) n' = KindedTyVar n' k @@ -164,40 +225,30 @@ replaceTyVarName (KindedTyVar n k) n' = KindedTyVar n' k \begin{code} splitHsInstDeclTy - :: Outputable name + :: OutputableBndr name => HsType name - -> ([HsTyVarBndr name], HsContext name, name, [HsType name]) + -> ([LHsTyVarBndr name], HsContext name, name, [LHsType name]) -- Split up an instance decl type, returning the pieces --- In interface files, the instance declaration head is created --- by HsTypes.toHsType, which does not guarantee to produce a --- HsForAllTy. For example, if we had the weird decl --- instance Foo T => Foo [T] --- then we'd get the instance type --- Foo T -> Foo [T] --- So when colleting the instance context, to be on the safe side --- we gather predicate arguments --- --- For source code, the parser ensures the type will have the right shape. --- (e.g. see ParseUtil.checkInstType) - splitHsInstDeclTy inst_ty = case inst_ty of - HsForAllTy (Just tvs) cxt1 tau - -> (tvs, cxt1++cxt2, cls, tys) - where - (cxt2, cls, tys) = split_tau tau - - other -> ([], cxt2, cls, tys) - where - (cxt2, cls, tys) = split_tau inst_ty - + HsParTy (L _ ty) -> splitHsInstDeclTy ty + HsForAllTy _ tvs cxt (L _ ty) -> split_tau tvs (unLoc cxt) ty + other -> split_tau [] [] other + -- The type vars should have been computed by now, even if they were implicit + where + split_tau tvs cxt (HsPredTy (HsClassP cls tys)) = (tvs, cxt, cls, tys) + split_tau tvs cxt (HsParTy (L _ ty)) = split_tau tvs cxt ty + +-- Splits HsType into the (init, last) parts +-- Breaks up any parens in the result type: +-- splitHsFunType (a -> (b -> c)) = ([a,b], c) +splitHsFunType :: LHsType name -> ([LHsType name], LHsType name) +splitHsFunType (L l (HsFunTy x y)) = (x:args, res) where - split_tau (HsFunTy (HsPredTy p) ty) = (p:ps, cls, tys) - where - (ps, cls, tys) = split_tau ty - split_tau (HsPredTy (HsClassP cls tys)) = ([], cls,tys) - split_tau other = pprPanic "splitHsInstDeclTy" (ppr inst_ty) + (args, res) = splitHsFunType y +splitHsFunType (L _ (HsParTy ty)) = splitHsFunType ty +splitHsFunType other = ([], other) \end{code} @@ -211,25 +262,31 @@ NB: these types get printed into interface files, so don't change the printing format lightly \begin{code} -instance (Outputable name) => Outputable (HsType name) where +instance (OutputableBndr name) => Outputable (HsType name) where ppr ty = pprHsType ty instance (Outputable name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar name) = ppr name ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind -instance Outputable name => Outputable (HsPred name) where - ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys) +instance OutputableBndr name => Outputable (HsPred name) where + ppr (HsClassP clas tys) = ppr clas <+> hsep (map (pprParendHsType.unLoc) tys) ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty] pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc -pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name - | otherwise = hsep [ppr name, dcolon, pprParendKind kind] +pprHsTyVarBndr name kind | isLiftedTypeKind kind = ppr name + | otherwise = hsep [ppr name, dcolon, pprParendKind kind] -pprHsForAll [] [] = empty -pprHsForAll tvs cxt = ptext SLIT("forall") <+> interppSP tvs <+> pprHsContext cxt +pprHsForAll exp tvs cxt + | show_forall = forall_part <+> pprHsContext (unLoc cxt) + | otherwise = pprHsContext (unLoc cxt) + where + show_forall = opt_PprStyle_Debug + || (not (null tvs) && is_explicit) + is_explicit = case exp of {Explicit -> True; Implicit -> False} + forall_part = ptext SLIT("forall") <+> interppSP tvs <> dot -pprHsContext :: (Outputable name) => HsContext name -> SDoc +pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc pprHsContext [] = empty pprHsContext cxt = ppr_hs_context cxt <+> ptext SLIT("=>") @@ -254,7 +311,7 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p -- printing works more-or-less as for Types -pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc +pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty pREC_TOP (prepare sty ty) pprParendHsType ty = ppr_mono_ty pREC_CON ty @@ -263,45 +320,45 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty -- (a) Remove outermost HsParTy parens -- (b) Drop top-level for-all type variables in user style -- since they are implicit in Haskell -prepare sty (HsParTy ty) = prepare sty ty -prepare sty (HsForAllTy _ cxt ty) | userStyle sty = (HsForAllTy Nothing cxt ty) +prepare sty (HsParTy ty) = prepare sty (unLoc ty) prepare sty ty = ty -ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty) +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) + +ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) = maybeParen ctxt_prec pREC_FUN $ - sep [pp_header, ppr_mono_ty pREC_TOP ty] - where - pp_header = case maybe_tvs of - Just tvs -> pprHsForAll tvs ctxt - Nothing -> pprHsContext ctxt + sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty] +-- gaw 2004 +ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppr b <> ppr ty ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2 ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (interpp'SP tys) -ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_ty pREC_TOP ty <+> dcolon <+> pprKind kind) -ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_ty pREC_TOP ty) -ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_ty pREC_TOP ty) +ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind) +ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty ctxt_prec (HsPredTy pred) = braces (ppr pred) ppr_mono_ty ctxt_prec (HsNumTy n) = integer n -- generics only +ppr_mono_ty ctxt_prec (HsSpliceTy s) = pprSplice s ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty] + hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty] ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = maybeParen ctxt_prec pREC_OP $ - ppr_mono_ty pREC_OP ty1 <+> ppr op <+> ppr_mono_ty pREC_OP ty2 + ppr_mono_lty pREC_OP ty1 <+> ppr op <+> ppr_mono_lty pREC_OP ty2 ppr_mono_ty ctxt_prec (HsParTy ty) - = parens (ppr_mono_ty pREC_TOP ty) + = parens (ppr_mono_lty pREC_TOP ty) -- Put the parens in where the user did -- But we still use the precedence stuff to add parens because -- toHsType doesn't put in any HsParTys, so we may still need them -------------------------- ppr_fun_ty ctxt_prec ty1 ty2 - = let p1 = ppr_mono_ty pREC_FUN ty1 - p2 = ppr_mono_ty pREC_TOP ty2 + = let p1 = ppr_mono_lty pREC_FUN ty1 + p2 = ppr_mono_lty pREC_TOP ty2 in maybeParen ctxt_prec pREC_FUN $ sep [p1, ptext SLIT("->") <+> p2]