import {-# SOURCE #-} HsPat ( LPat )
import HsTypes ( LHsType, PostTcType )
+import Type ( Type )
import Name ( Name )
import NameSet ( NameSet, elemNameSet )
-import BasicTypes ( IPName, RecFlag(..), Activation(..), Fixity )
+import BasicTypes ( IPName, RecFlag(..), InlineSpec(..), Fixity )
import Outputable
import SrcLoc ( Located(..), SrcSpan, unLoc )
import Util ( sortLe )
type LHsBind id = Located (HsBind id)
data HsBind id
- = FunBind (Located id)
- -- Used for both functions f x = e
- -- and variables f = \x -> e
- -- Reason: the Match stuff lets us have an optional
- -- result type sig f :: a->a = ...mentions a...
- --
- -- This also means that instance decls can only have
- -- FunBinds, so if you change this, you'll need to
- -- change e.g. rnMethodBinds
- Bool -- True => infix declaration
- (MatchGroup id)
- NameSet -- After the renamer, this contains a superset of the
+ = FunBind { -- FunBind is used for both functions f x = e
+ -- and variables f = \x -> e
+-- Reason 1: the Match stuff lets us have an optional
+-- result type sig f :: a->a = ...mentions a...
+--
+-- Reason 2: Special case for type inference: see TcBinds.tcMonoBinds
+--
+-- Reason 3: instance decls can only have FunBinds, which is convenient
+-- If you change this, you'll need tochange e.g. rnMethodBinds
+
+ fun_id :: Located id,
+
+ fun_infix :: Bool, -- True => infix declaration
+
+ fun_matches :: MatchGroup id, -- The payload
+
+ fun_co_fn :: ExprCoFn, -- Coercion from the type of the MatchGroup to the type of
+ -- the Id. Example:
+ -- f :: Int -> forall a. a -> a
+ -- f x y = y
+ -- Then the MatchGroup will have type (Int -> a' -> a')
+ -- (with a free type variable a'). The coercion will take
+ -- a CoreExpr of this type and convert it to a CoreExpr of
+ -- type Int -> forall a'. a' -> a'
+ -- Notice that the coercion captures the free a'. That's
+ -- why coercions are (CoreExpr -> CoreExpr), rather than
+ -- just CoreExpr (with a functional type)
+
+ bind_fvs :: NameSet -- After the renamer, this contains a superset of the
-- Names of the other binders in this binding group that
-- are free in the RHS of the defn
-- Before renaming, and after typechecking,
-- the field is unused; it's just an error thunk
-
- | PatBind (LPat id) -- The pattern is never a simple variable;
- -- That case is done by FunBind
- (GRHSs id)
- PostTcType -- Type of the GRHSs
- NameSet -- Same as for FunBind
-
- | VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike
- -- All VarBinds are introduced by the type checker
- -- Located only for consistency
-
- | AbsBinds -- Binds abstraction; TRANSLATION
- [TyVar] -- Type variables
- [DictId] -- Dicts
- [([TyVar], id, id, [Prag])] -- (tvs, poly_id, mono_id, prags)
- (LHsBinds id) -- The dictionary bindings and typechecked user bindings
+ }
+
+ | PatBind { -- The pattern is never a simple variable;
+ -- That case is done by FunBind
+ pat_lhs :: LPat id,
+ pat_rhs :: GRHSs id,
+ pat_rhs_ty :: PostTcType, -- Type of the GRHSs
+ bind_fvs :: NameSet -- Same as for FunBind
+ }
+
+ | VarBind { -- Dictionary binding and suchlike
+ var_id :: id, -- All VarBinds are introduced by the type checker
+ var_rhs :: LHsExpr id -- Located only for consistency
+ }
+
+ | AbsBinds { -- Binds abstraction; TRANSLATION
+ abs_tvs :: [TyVar],
+ abs_dicts :: [DictId],
+ abs_exports :: [([TyVar], id, id, [Prag])], -- (tvs, poly_id, mono_id, prags)
+ abs_binds :: LHsBinds id -- The dictionary bindings and typechecked user bindings
-- mixed up together; you can tell the dict bindings because
-- they are all VarBinds
-
+ }
-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
--
-- Creates bindings for (polymorphic, overloaded) poly_f
ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
-ppr_monobind (PatBind pat grhss _ _) = pprPatBind pat grhss
-ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs)
-ppr_monobind (FunBind fun inf matches _) = pprFunBind (unLoc fun) matches
+ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss
+ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = ppr var <+> equals <+> pprExpr (unLoc rhs)
+ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches
-- ToDo: print infix if appropriate
-ppr_monobind (AbsBinds tyvars dictvars exports val_binds)
+ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
+ abs_exports = exports, abs_binds = val_binds })
= sep [ptext SLIT("AbsBinds"),
brackets (interpp'SP tyvars),
brackets (interpp'SP dictvars),
%************************************************************************
%* *
+\subsection{Coercion functions}
+%* *
+%************************************************************************
+
+\begin{code}
+-- A Coercion is an expression with a hole in it
+-- We need coercions to have concrete form so that we can zonk them
+
+data ExprCoFn
+ = CoHole -- The identity coercion
+ | CoCompose ExprCoFn ExprCoFn
+ | CoApps ExprCoFn [Id] -- Non-empty list
+ | CoTyApps ExprCoFn [Type] -- in all of these
+ | CoLams [Id] ExprCoFn -- so that the identity coercion
+ | CoTyLams [TyVar] ExprCoFn -- is just Hole
+ | CoLet (LHsBinds Id) ExprCoFn -- Would be nicer to be core bindings
+
+(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
+(<.>) = CoCompose
+
+idCoercion :: ExprCoFn
+idCoercion = CoHole
+
+isIdCoercion :: ExprCoFn -> Bool
+isIdCoercion CoHole = True
+isIdCoercion other = False
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{@Sig@: type signatures and value-modifying user pragmas}
%* *
%************************************************************************
type LSig name = Located (Sig name)
data Sig name
- = Sig (Located name) -- a bog-std type signature
+ = TypeSig (Located name) -- A bog-std type signature
(LHsType name)
- | SpecSig (Located name) -- specialise a function or datatype ...
+ | SpecSig (Located name) -- Specialise a function or datatype ...
(LHsType name) -- ... to these types
+ InlineSpec
- | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f
- (Located name) -- Function name
- Activation -- When inlining is *active*
+ | InlineSig (Located name) -- Function name
+ InlineSpec
| SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
-- current instance decl
-- A Prag conveys pragmas from the type checker to the desugarer
data Prag
- = InlinePrag
- Bool -- True <=> INLINE, False <=> NOINLINE
- Activation
+ = InlinePrag
+ InlineSpec
| SpecPrag
(HsExpr Id) -- An expression, of the given specialised type, which
PostTcType -- specialises the polymorphic function
[Id] -- Dicts mentioned free in the expression
+ InlineSpec -- Inlining spec for the specialised function
-isInlinePrag (InlinePrag _ _) = True
-isInlinePrag prag = False
+isInlinePrag (InlinePrag _) = True
+isInlinePrag prag = False
-isSpecPrag (SpecPrag _ _ _) = True
-isSpecPrag prag = False
+isSpecPrag (SpecPrag _ _ _ _) = True
+isSpecPrag prag = False
\end{code}
\begin{code}
okBindSig ns sig = sigForThisGroup ns sig
okHsBootSig :: LSig Name -> Bool
-okHsBootSig (L _ (Sig _ _)) = True
-okHsBootSig (L _ (FixSig _)) = True
-okHsBootSig sig = False
+okHsBootSig (L _ (TypeSig _ _)) = True
+okHsBootSig (L _ (FixSig _)) = True
+okHsBootSig sig = False
okClsDclSig :: LSig Name -> Bool
okClsDclSig (L _ (SpecInstSig _)) = False
okInstDclSig :: NameSet -> LSig Name -> Bool
okInstDclSig ns lsig@(L _ sig) = ok ns sig
where
- ok ns (Sig _ _) = False
+ ok ns (TypeSig _ _) = False
ok ns (FixSig _) = False
ok ns (SpecInstSig _) = True
ok ns sig = sigForThisGroup ns lsig
sigName :: LSig name -> Maybe name
sigName (L _ sig) = f sig
where
- f (Sig n _) = Just (unLoc n)
- f (SpecSig n _) = Just (unLoc n)
- f (InlineSig _ n _) = Just (unLoc n)
+ f (TypeSig n _) = Just (unLoc n)
+ f (SpecSig n _ _) = Just (unLoc n)
+ f (InlineSig n _) = Just (unLoc n)
f (FixSig (FixitySig n _)) = Just (unLoc n)
f other = Nothing
isFixityLSig :: LSig name -> Bool
-isFixityLSig (L _ (FixSig _)) = True
-isFixityLSig _ = False
+isFixityLSig (L _ (FixSig {})) = True
+isFixityLSig _ = False
isVanillaLSig :: LSig name -> Bool
-isVanillaLSig (L _(Sig name _)) = True
+isVanillaLSig (L _(TypeSig {})) = True
isVanillaLSig sig = False
isSpecLSig :: LSig name -> Bool
-isSpecLSig (L _(SpecSig name _)) = True
-isSpecLSig sig = False
+isSpecLSig (L _(SpecSig {})) = True
+isSpecLSig sig = False
-isSpecInstLSig (L _ (SpecInstSig _)) = True
-isSpecInstLSig sig = False
+isSpecInstLSig (L _ (SpecInstSig {})) = True
+isSpecInstLSig sig = False
isPragLSig :: LSig name -> Bool
-- Identifies pragmas
-isPragLSig (L _ (SpecSig _ _)) = True
-isPragLSig (L _ (InlineSig _ _ _)) = True
-isPragLSig other = False
-
-hsSigDoc (Sig _ _) = ptext SLIT("type signature")
-hsSigDoc (SpecSig _ _) = ptext SLIT("SPECIALISE pragma")
-hsSigDoc (InlineSig True _ _) = ptext SLIT("INLINE pragma")
-hsSigDoc (InlineSig False _ _) = ptext SLIT("NOINLINE pragma")
-hsSigDoc (SpecInstSig _) = ptext SLIT("SPECIALISE instance pragma")
-hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration")
+isPragLSig (L _ (SpecSig {})) = True
+isPragLSig (L _ (InlineSig {})) = True
+isPragLSig other = False
+
+isInlineLSig :: LSig name -> Bool
+ -- Identifies inline pragmas
+isInlineLSig (L _ (InlineSig {})) = True
+isInlineLSig other = False
+
+hsSigDoc (TypeSig {}) = ptext SLIT("type signature")
+hsSigDoc (SpecSig {}) = ptext SLIT("SPECIALISE pragma")
+hsSigDoc (InlineSig _ spec) = ppr spec <+> ptext SLIT("pragma")
+hsSigDoc (SpecInstSig {}) = ptext SLIT("SPECIALISE instance pragma")
+hsSigDoc (FixSig {}) = ptext SLIT("fixity declaration")
\end{code}
Signature equality is used when checking for duplicate signatures
\begin{code}
eqHsSig :: LSig Name -> LSig Name -> Bool
eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
-eqHsSig (L _ (Sig n1 _)) (L _ (Sig n2 _)) = unLoc n1 == unLoc n2
-eqHsSig (L _ (InlineSig b1 n1 _)) (L _ (InlineSig b2 n2 _)) = b1 == b2 && unLoc n1 == unLoc n2
+eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
+eqHsSig (L _ (InlineSig n1 s1)) (L _ (InlineSig n2 s2)) = s1 == s2 && unLoc n1 == unLoc n2
-- For specialisations, we don't have equality over
-- HsType, so it's not convenient to spot duplicate
-- specialisations here. Check for this later, when we're in Type land
ppr sig = ppr_sig sig
ppr_sig :: OutputableBndr name => Sig name -> SDoc
-ppr_sig (Sig var ty) = pprVarSig (unLoc var) ty
+ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) ty
ppr_sig (FixSig fix_sig) = ppr fix_sig
-ppr_sig (SpecSig var ty) = pragBrackets (pprSpec var ty)
-ppr_sig (InlineSig inl var phase) = pragBrackets (pprInline var inl phase)
+ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var ty inl)
+ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var)
ppr_sig (SpecInstSig ty) = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
instance Outputable name => Outputable (FixitySig name) where
pragBrackets :: SDoc -> SDoc
pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}")
-pprInline :: Outputable id => id -> Bool -> Activation -> SDoc
-pprInline var True phase = hsep [ptext SLIT("INLINE"), ppr phase, ppr var]
-pprInline var False phase = hsep [ptext SLIT("NOINLINE"), ppr phase, ppr var]
-
pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
-pprSpec :: (Outputable id, Outputable ty) => id -> ty -> SDoc
-pprSpec var ty = sep [ptext SLIT("SPECIALIZE") <+> pprVarSig var ty]
+pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
+pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
pprPrag :: Outputable id => id -> Prag -> SDoc
-pprPrag var (InlinePrag inl act) = pprInline var inl act
-pprPrag var (SpecPrag expr ty _) = pprSpec var ty
+pprPrag var (InlinePrag inl) = ppr inl <+> ppr var
+pprPrag var (SpecPrag expr ty _ inl) = pprSpec var ty inl
\end{code}
projects / ghc-hetmet.git / blobdiff