%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 19921998
%
\section[HsBinds]{Abstract syntax: toplevel bindings and signatures}
Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
\begin{code}
module HsBinds where
import HsExpr ( pprExpr, LHsExpr,
MatchGroup, pprFunBind,
GRHSs, pprPatBind )
import HsPat ( LPat )
import HsTypes
import PprCore ()
import Coercion
import Type
import Name
import NameSet
import BasicTypes
import Outputable
import SrcLoc
import Util
import VarEnv
import Var
import Bag
import Unique
import FastString
import Data.IORef( IORef )
import Data.Data hiding ( Fixity )
\end{code}
%************************************************************************
%* *
\subsection{Bindings: @BindGroup@}
%* *
%************************************************************************
Global bindings (where clauses)
\begin{code}
type HsLocalBinds id = HsLocalBindsLR id id
data HsLocalBindsLR idL idR
= HsValBinds (HsValBindsLR idL idR)
| HsIPBinds (HsIPBinds idR)
| EmptyLocalBinds
deriving (Data, Typeable)
type HsValBinds id = HsValBindsLR id id
data HsValBindsLR idL idR
= ValBindsIn
(LHsBindsLR idL idR) [LSig idR]
| ValBindsOut
[(RecFlag, LHsBinds idL)]
[LSig Name]
deriving (Data, Typeable)
type LHsBinds id = Bag (LHsBind id)
type LHsBind id = Located (HsBind id)
type HsBind id = HsBindLR id id
type LHsBindLR idL idR = Located (HsBindLR idL idR)
type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
data HsBindLR idL idR
=
FunBind {
fun_id :: Located idL,
fun_infix :: Bool,
fun_matches :: MatchGroup idR,
fun_co_fn :: HsWrapper,
bind_fvs :: NameSet,
fun_tick :: Maybe (Int,[Id])
}
| PatBind {
pat_lhs :: LPat idL,
pat_rhs :: GRHSs idR,
pat_rhs_ty :: PostTcType,
bind_fvs :: NameSet
}
| VarBind {
var_id :: idL,
var_rhs :: LHsExpr idR,
var_inline :: Bool
}
| AbsBinds {
abs_tvs :: [TyVar],
abs_ev_vars :: [EvVar],
abs_exports :: [([TyVar], idL, idL, TcSpecPrags)],
abs_ev_binds :: TcEvBinds,
abs_binds :: LHsBinds idL
}
deriving (Data, Typeable)
placeHolderNames :: NameSet
placeHolderNames = panic "placeHolderNames"
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
ppr (HsValBinds bs) = ppr bs
ppr (HsIPBinds bs) = ppr bs
ppr EmptyLocalBinds = empty
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
ppr (ValBindsIn binds sigs)
= pprValBindsForUser binds sigs
ppr (ValBindsOut sccs sigs)
= getPprStyle $ \ sty ->
if debugStyle sty then
vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
else
pprValBindsForUser (unionManyBags (map snd sccs)) sigs
where
ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
pp_rec Recursive = ptext (sLit "rec")
pp_rec NonRecursive = ptext (sLit "nonrec")
pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
=> LHsBindsLR idL idR -> [LSig id2] -> SDoc
pprValBindsForUser binds sigs
= pprDeeperList vcat (map snd (sort_by_loc decls))
where
decls :: [(SrcSpan, SDoc)]
decls = [(loc, ppr sig) | L loc sig <- sigs] ++
[(loc, ppr bind) | L loc bind <- bagToList binds]
sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace
emptyLocalBinds :: HsLocalBindsLR a b
emptyLocalBinds = EmptyLocalBinds
isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
isEmptyLocalBinds EmptyLocalBinds = True
isEmptyValBinds :: HsValBindsLR a b -> Bool
isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
emptyValBindsIn = ValBindsIn emptyBag []
emptyValBindsOut = ValBindsOut [] []
emptyLHsBinds :: LHsBindsLR idL idR
emptyLHsBinds = emptyBag
isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
isEmptyLHsBinds = isEmptyBag
plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
= ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
= ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
getTypeSigNames :: HsValBinds a -> NameSet
getTypeSigNames (ValBindsIn {})
= panic "getTypeSigNames"
getTypeSigNames (ValBindsOut _ sigs)
= mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs]
\end{code}
What AbsBinds means
~~~~~~~~~~~~~~~~~~~
AbsBinds tvs
[d1,d2]
[(tvs1, f1p, f1m),
(tvs2, f2p, f2m)]
BIND
means
f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
in fm
gp = ...same again, with gm instead of fm
This is a pretty bad translation, because it duplicates all the bindings.
So the desugarer tries to do a better job:
fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
(fm,gm) -> fm
..ditto for gp..
tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
in (fm,gm)
\begin{code}
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
ppr mbind = ppr_monobind mbind
ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
= pprPatBind pat grhss
ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
= sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
fun_co_fn = wrap,
fun_matches = matches,
fun_tick = tick })
= pprTicks empty (case tick of
Nothing -> empty
Just t -> text "-- tick id = " <> ppr t)
$$ pprFunBind (unLoc fun) inf matches
$$ ifPprDebug (ppr wrap)
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, abs_exports = exports, abs_binds = val_binds
, abs_ev_binds = ev_binds })
= sep [ptext (sLit "AbsBinds"),
brackets (interpp'SP tyvars),
brackets (interpp'SP dictvars),
brackets (sep (punctuate comma (map ppr_exp exports)))]
$$
nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
$$ pprLHsBinds val_binds )
$$
ifPprDebug (ppr ev_binds)
where
ppr_exp (tvs, gbl, lcl, prags)
= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
nest 2 (pprTcSpecPrags prags)]
\end{code}
\begin{code}
pprTicks :: SDoc -> SDoc -> SDoc
pprTicks pp_no_debug pp_when_debug
= getPprStyle (\ sty -> if debugStyle sty then pp_when_debug
else pp_no_debug)
\end{code}
%************************************************************************
%* *
Implicit parameter bindings
%* *
%************************************************************************
\begin{code}
data HsIPBinds id
= IPBinds
[LIPBind id]
TcEvBinds
deriving (Data, Typeable)
isEmptyIPBinds :: HsIPBinds id -> Bool
isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
type LIPBind id = Located (IPBind id)
data IPBind id
= IPBind
(IPName id)
(LHsExpr id)
deriving (Data, Typeable)
instance (OutputableBndr id) => Outputable (HsIPBinds id) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
$$ ifPprDebug (ppr ds)
instance (OutputableBndr id) => Outputable (IPBind id) where
ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
\end{code}
%************************************************************************
%* *
\subsection{Coercion functions}
%* *
%************************************************************************
\begin{code}
data HsWrapper
= WpHole
| WpCompose HsWrapper HsWrapper
| WpCast Coercion
| WpEvLam EvVar
| WpEvApp EvTerm
| WpTyLam TyVar
| WpTyApp Type
| WpLet TcEvBinds
deriving (Data, Typeable)
data TcEvBinds
= TcEvBinds
EvBindsVar
| EvBinds
(Bag EvBind)
deriving( Typeable )
data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
type EvBindMap = VarEnv EvBind
emptyEvBindMap :: EvBindMap
emptyEvBindMap = emptyVarEnv
extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
extendEvBinds bs v t = extendVarEnv bs v (EvBind v t)
lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
lookupEvBind = lookupVarEnv
evBindMapBinds :: EvBindMap -> Bag EvBind
evBindMapBinds = foldVarEnv consBag emptyBag
instance Data TcEvBinds where
toConstr _ = abstractConstr "TcEvBinds"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "TcEvBinds"
data EvBind = EvBind EvVar EvTerm
data EvTerm
= EvId EvId
| EvCoercion Coercion
| EvCast EvVar Coercion
| EvDFunApp DFunId
[Type] [EvVar]
| EvSuperClass DictId Int
deriving( Data, Typeable)
evVarTerm :: EvVar -> EvTerm
evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v)
| otherwise = EvId v
\end{code}
Note [EvBinds/EvTerm]
~~~~~~~~~~~~~~~~~~~~~
How evidence is created and updated. Bindings for dictionaries,
and coercions and implicit parameters are carried around in TcEvBinds
which during constraint generation and simplification is always of the
form (TcEvBinds ref). After constraint simplification is finished it
will be transformed to t an (EvBinds ev_bag).
Evidence for coercions *SHOULD* be filled in using the TcEvBinds
However, all EvVars that correspond to *wanted* coercion terms in
an EvBind must be mutable variables so that they can be readily
inlined (by zonking) after constraint simplification is finished.
Conclusion: a new wanted coercion variable should be made mutable.
[Notice though that evidence variables that bind coercion terms
from super classes will be "given" and hence rigid]
\begin{code}
emptyTcEvBinds :: TcEvBinds
emptyTcEvBinds = EvBinds emptyBag
isEmptyTcEvBinds :: TcEvBinds -> Bool
isEmptyTcEvBinds (EvBinds b) = isEmptyBag b
isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
(<.>) :: HsWrapper -> HsWrapper -> HsWrapper
WpHole <.> c = c
c <.> WpHole = c
c1 <.> c2 = c1 `WpCompose` c2
mkWpTyApps :: [Type] -> HsWrapper
mkWpTyApps tys = mk_co_app_fn WpTyApp tys
mkWpEvApps :: [EvTerm] -> HsWrapper
mkWpEvApps args = mk_co_app_fn WpEvApp args
mkWpEvVarApps :: [EvVar] -> HsWrapper
mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs)
mkWpTyLams :: [TyVar] -> HsWrapper
mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
mkWpLams :: [Var] -> HsWrapper
mkWpLams ids = mk_co_lam_fn WpEvLam ids
mkWpLet :: TcEvBinds -> HsWrapper
mkWpLet (EvBinds b) | isEmptyBag b = WpHole
mkWpLet ev_binds = WpLet ev_binds
mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
mk_co_lam_fn f as = foldr (\x wrap -> f x `WpCompose` wrap) WpHole as
mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
mk_co_app_fn f as = foldr (\x wrap -> wrap `WpCompose` f x) WpHole as
idHsWrapper :: HsWrapper
idHsWrapper = WpHole
isIdHsWrapper :: HsWrapper -> Bool
isIdHsWrapper WpHole = True
isIdHsWrapper _ = False
\end{code}
Pretty printing
\begin{code}
instance Outputable HsWrapper where
ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
pprHsWrapper :: SDoc -> HsWrapper -> SDoc
pprHsWrapper doc wrap
= getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc)
where
help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc
help it WpHole = it
help it (WpCompose f1 f2) = help (help it f2) f1
help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
<+> pprParendType co)]
help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)]
help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False]
help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False]
pp_bndr v = pprBndr LambdaBind v <> dot
add_parens, no_parens :: SDoc -> Bool -> SDoc
add_parens d True = parens d
add_parens d False = d
no_parens d _ = d
instance Outputable TcEvBinds where
ppr (TcEvBinds v) = ppr v
ppr (EvBinds bs) = ptext (sLit "EvBinds") <> braces (ppr bs)
instance Outputable EvBindsVar where
ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)
instance Outputable EvBind where
ppr (EvBind v e) = ppr v <+> equals <+> ppr e
instance Outputable EvTerm where
ppr (EvId v) = ppr v
ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
ppr (EvCoercion co) = ppr co
ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys
, ppr ts ]
\end{code}
%************************************************************************
%* *
\subsection{@Sig@: type signatures and valuemodifying user pragmas}
%* *
%************************************************************************
It is convenient to lump ``valuemodifying'' userpragmas (e.g.,
``specialise this function to these four types...'') in with type
signatures. Then all the machinery to move them into place, etc.,
serves for both.
\begin{code}
type LSig name = Located (Sig name)
data Sig name
=
TypeSig (Located name) (LHsType name)
| IdSig Id
| FixSig (FixitySig name)
| InlineSig (Located name)
InlinePragma
| SpecSig (Located name)
(LHsType name)
InlinePragma
| SpecInstSig (LHsType name)
deriving (Data, Typeable)
type LFixitySig name = Located (FixitySig name)
data FixitySig name = FixitySig (Located name) Fixity
deriving (Data, Typeable)
data TcSpecPrags
= IsDefaultMethod
| SpecPrags [LTcSpecPrag]
deriving (Data, Typeable)
type LTcSpecPrag = Located TcSpecPrag
data TcSpecPrag
= SpecPrag
Id
HsWrapper
InlinePragma
deriving (Data, Typeable)
noSpecPrags :: TcSpecPrags
noSpecPrags = SpecPrags []
hasSpecPrags :: TcSpecPrags -> Bool
hasSpecPrags (SpecPrags ps) = not (null ps)
hasSpecPrags IsDefaultMethod = False
isDefaultMethod :: TcSpecPrags -> Bool
isDefaultMethod IsDefaultMethod = True
isDefaultMethod (SpecPrags {}) = False
\end{code}
\begin{code}
okBindSig :: Sig a -> Bool
okBindSig _ = True
okHsBootSig :: Sig a -> Bool
okHsBootSig (TypeSig _ _) = True
okHsBootSig (FixSig _) = True
okHsBootSig _ = False
okClsDclSig :: Sig a -> Bool
okClsDclSig (SpecInstSig _) = False
okClsDclSig _ = True
okInstDclSig :: Sig a -> Bool
okInstDclSig (TypeSig _ _) = False
okInstDclSig (FixSig _) = False
okInstDclSig _ = True
sigForThisGroup :: NameSet -> LSig Name -> Bool
sigForThisGroup ns sig
= case sigName sig of
Nothing -> False
Just n -> n `elemNameSet` ns
sigName :: LSig name -> Maybe name
sigName (L _ sig) = sigNameNoLoc sig
sigNameNoLoc :: Sig name -> Maybe name
sigNameNoLoc (TypeSig n _) = Just (unLoc n)
sigNameNoLoc (SpecSig n _ _) = Just (unLoc n)
sigNameNoLoc (InlineSig n _) = Just (unLoc n)
sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
sigNameNoLoc _ = Nothing
isFixityLSig :: LSig name -> Bool
isFixityLSig (L _ (FixSig {})) = True
isFixityLSig _ = False
isVanillaLSig :: LSig name -> Bool
isVanillaLSig (L _(TypeSig {})) = True
isVanillaLSig _ = False
isTypeLSig :: LSig name -> Bool
isTypeLSig (L _(TypeSig {})) = True
isTypeLSig (L _(IdSig {})) = True
isTypeLSig _ = False
isSpecLSig :: LSig name -> Bool
isSpecLSig (L _(SpecSig {})) = True
isSpecLSig _ = False
isSpecInstLSig :: LSig name -> Bool
isSpecInstLSig (L _ (SpecInstSig {})) = True
isSpecInstLSig _ = False
isPragLSig :: LSig name -> Bool
isPragLSig (L _ (SpecSig {})) = True
isPragLSig (L _ (InlineSig {})) = True
isPragLSig _ = False
isInlineLSig :: LSig name -> Bool
isInlineLSig (L _ (InlineSig {})) = True
isInlineLSig _ = False
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
hsSigDoc (IdSig {}) = ptext (sLit "id signature")
hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
hsSigDoc (InlineSig {}) = ptext (sLit "INLINE 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 :: Eq a => LSig a -> LSig a -> Bool
eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2
eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2
eqHsSig _other1 _other2 = False
\end{code}
\begin{code}
instance (OutputableBndr name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty)
ppr_sig (IdSig id) = pprVarSig id (ppr (varType id))
ppr_sig (FixSig fix_sig) = ppr fix_sig
ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr 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
ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
pragBrackets :: SDoc -> SDoc
pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
pprVarSig :: (Outputable id) => id -> SDoc -> SDoc
pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty]
pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty
where
pp_inl | isDefaultInlinePragma inl = empty
| otherwise = ppr inl
pprTcSpecPrags :: TcSpecPrags -> SDoc
pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
instance Outputable TcSpecPrag where
ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
\end{code}