module HsBinds where
import HsExpr ( pprExpr, LHsExpr,
MatchGroup, pprFunBind,
GRHSs, pprPatBind )
import HsPat ( LPat )
import PlaceHolder ( PostTc,PostRn,DataId )
import HsTypes
import PprCore ()
import CoreSyn
import TcEvidence
import Type
import Name
import NameSet
import BasicTypes
import Outputable
import SrcLoc
import Var
import Bag
import FastString
import BooleanFormula (BooleanFormula)
import Data.Data hiding ( Fixity )
import Data.List
import Data.Ord
import Data.Foldable ( Foldable(..) )
#if __GLASGOW_HASKELL__ < 709
import Data.Traversable ( Traversable(..) )
import Data.Monoid ( mappend )
import Control.Applicative hiding (empty)
#else
import Control.Applicative ((<$>))
#endif
type HsLocalBinds id = HsLocalBindsLR id id
data HsLocalBindsLR idL idR
= HsValBinds (HsValBindsLR idL idR)
| HsIPBinds (HsIPBinds idR)
| EmptyLocalBinds
deriving (Typeable)
deriving instance (DataId idL, DataId idR)
=> Data (HsLocalBindsLR idL idR)
type HsValBinds id = HsValBindsLR id id
data HsValBindsLR idL idR
=
ValBindsIn
(LHsBindsLR idL idR) [LSig idR]
| ValBindsOut
[(RecFlag, LHsBinds idL)]
[LSig Name]
deriving (Typeable)
deriving instance (DataId idL, DataId idR)
=> Data (HsValBindsLR idL idR)
type LHsBind id = LHsBindLR id id
type LHsBinds id = LHsBindsLR id id
type HsBind id = HsBindLR id id
type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
type LHsBindLR idL idR = Located (HsBindLR idL idR)
data HsBindLR idL idR
=
FunBind {
fun_id :: Located idL,
fun_infix :: Bool,
fun_matches :: MatchGroup idR (LHsExpr idR),
fun_co_fn :: HsWrapper,
bind_fvs :: PostRn idL NameSet,
fun_tick :: [Tickish Id]
}
| PatBind {
pat_lhs :: LPat idL,
pat_rhs :: GRHSs idR (LHsExpr idR),
pat_rhs_ty :: PostTc idR Type,
bind_fvs :: PostRn idL NameSet,
pat_ticks :: ([Tickish Id], [[Tickish Id]])
}
| VarBind {
var_id :: idL,
var_rhs :: LHsExpr idR,
var_inline :: Bool
}
| AbsBinds {
abs_tvs :: [TyVar],
abs_ev_vars :: [EvVar],
abs_exports :: [ABExport idL],
abs_ev_binds :: TcEvBinds,
abs_binds :: LHsBinds idL
}
| PatSynBind (PatSynBind idL idR)
deriving (Typeable)
deriving instance (DataId idL, DataId idR)
=> Data (HsBindLR idL idR)
data ABExport id
= ABE { abe_poly :: id
, abe_mono :: id
, abe_wrap :: HsWrapper
, abe_prags :: TcSpecPrags
} deriving (Data, Typeable)
data PatSynBind idL idR
= PSB { psb_id :: Located idL,
psb_fvs :: PostRn idR NameSet,
psb_args :: HsPatSynDetails (Located idR),
psb_def :: LPat idR,
psb_dir :: HsPatSynDir idR
} deriving (Typeable)
deriving instance (DataId idL, DataId idR )
=> Data (PatSynBind idL idR)
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)
= pprDeclList (pprLHsBindsForUser binds sigs)
ppr (ValBindsOut sccs sigs)
= getPprStyle $ \ sty ->
if debugStyle sty then
vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
else
pprDeclList (pprLHsBindsForUser (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")
pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map ppr (bagToList binds))
pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
=> LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
pprLHsBindsForUser binds sigs
= 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 = sortBy (comparing fst) decls
pprDeclList :: [SDoc] -> SDoc
pprDeclList ds = pprDeeperList vcat ds
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)
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
getTypeSigNames :: HsValBinds a -> NameSet
getTypeSigNames (ValBindsOut _ sigs)
= mkNameSet [unLoc n | L _ (TypeSig names _ _) <- sigs, n <- names]
getTypeSigNames _
= panic "HsBinds.getTypeSigNames"
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 = ticks })
= pprTicks empty (if null ticks then empty
else text "-- ticks = " <> ppr ticks)
$$ ifPprDebug (pprBndr LetBind (unLoc fun))
$$ pprFunBind (unLoc fun) inf matches
$$ ifPprDebug (ppr wrap)
ppr_monobind (PatSynBind psb) = ppr psb
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, abs_exports = exports, abs_binds = val_binds
, abs_ev_binds = ev_binds })
= hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars)
<+> brackets (interpp'SP dictvars))
2 $ braces $ vcat
[ ptext (sLit "Exports:") <+> brackets (sep (punctuate comma (map ppr exports)))
, ptext (sLit "Exported types:") <+> vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
, ptext (sLit "Binds:") <+> pprLHsBinds val_binds
, ifPprDebug (ptext (sLit "Evidence:") <+> ppr ev_binds) ]
instance (OutputableBndr id) => Outputable (ABExport id) where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (ppr wrap)]
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir })
= ppr_lhs <+> ppr_rhs
where
ppr_lhs = ptext (sLit "pattern") <+> ppr_details
ppr_simple syntax = syntax <+> ppr pat
(is_infix, ppr_details) = case details of
InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2])
PrefixPatSyn vs -> (False, hsep (pprPrefixOcc psyn : map ppr vs))
ppr_rhs = case dir of
Unidirectional -> ppr_simple (ptext (sLit "<-"))
ImplicitBidirectional -> ppr_simple equals
ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$
(nest 2 $ pprFunBind psyn is_infix mg)
pprTicks :: SDoc -> SDoc -> SDoc
pprTicks pp_no_debug pp_when_debug
= getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty
then pp_when_debug
else pp_no_debug)
data HsIPBinds id
= IPBinds
[LIPBind id]
TcEvBinds
deriving (Typeable)
deriving instance (DataId id) => Data (HsIPBinds id)
isEmptyIPBinds :: HsIPBinds id -> Bool
isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
type LIPBind id = Located (IPBind id)
data IPBind id
= IPBind (Either HsIPName id) (LHsExpr id)
deriving (Typeable)
deriving instance (DataId name) => Data (IPBind name)
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 lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of
Left ip -> pprBndr LetBind ip
Right id -> pprBndr LetBind id
type LSig name = Located (Sig name)
data Sig name
=
TypeSig [Located name] (LHsType name) (PostRn name [Name])
| PatSynSig (Located name)
(HsExplicitFlag, LHsTyVarBndrs name)
(LHsContext name)
(LHsContext name)
(LHsType name)
| GenericSig [Located name] (LHsType name)
| IdSig Id
| FixSig (FixitySig name)
| InlineSig (Located name)
InlinePragma
| SpecSig (Located name)
[LHsType name]
InlinePragma
| SpecInstSig (LHsType name)
| MinimalSig (BooleanFormula (Located name))
deriving (Typeable)
deriving instance (DataId name) => Data (Sig name)
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
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 _(GenericSig {})) = 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
isMinimalLSig :: LSig name -> Bool
isMinimalLSig (L _ (MinimalSig {})) = True
isMinimalLSig _ = False
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
hsSigDoc (PatSynSig {}) = ptext (sLit "pattern synonym signature")
hsSigDoc (GenericSig {}) = ptext (sLit "default type signature")
hsSigDoc (IdSig {}) = ptext (sLit "id signature")
hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma")
hsSigDoc (SpecInstSig {}) = ptext (sLit "SPECIALISE instance pragma")
hsSigDoc (FixSig {}) = ptext (sLit "fixity declaration")
hsSigDoc (MinimalSig {}) = ptext (sLit "MINIMAL pragma")
instance (OutputableBndr name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (TypeSig vars ty _wcs) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (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 (unLoc var) (interpp'SP ty) inl)
ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
ppr_sig (MinimalSig bf) = pragBrackets (pprMinimalSig bf)
ppr_sig (PatSynSig name (flag, qtvs) (L _ prov) (L _ req) ty)
= pprPatSynSig (unLoc name) False
(pprHsForAll flag qtvs (noLoc []))
(pprHsContextMaybe prov) (pprHsContextMaybe req)
(ppr ty)
pprPatSynSig :: (OutputableBndr name)
=> name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
pprPatSynSig ident _is_bidir tvs prov req ty
= ptext (sLit "pattern") <+> pprPrefixOcc ident <+> dcolon <+>
tvs <+> context <+> ty
where
context = case (prov, req) of
(Nothing, Nothing) -> empty
(Nothing, Just req) -> parens empty <+> darrow <+> req <+> darrow
(Just prov, Nothing) -> prov <+> darrow
(Just prov, Just req) -> prov <+> darrow <+> req <+> darrow
instance OutputableBndr name => Outputable (FixitySig name) where
ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
where
pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
pragBrackets :: SDoc -> SDoc
pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
where
pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
pprSpec :: (OutputableBndr 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
pprMinimalSig :: OutputableBndr name => BooleanFormula (Located name) -> SDoc
pprMinimalSig bf = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf)
data HsPatSynDetails a
= InfixPatSyn a a
| PrefixPatSyn [a]
deriving (Data, Typeable)
instance Functor HsPatSynDetails where
fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)
fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)
instance Foldable HsPatSynDetails where
foldMap f (InfixPatSyn left right) = f left `mappend` f right
foldMap f (PrefixPatSyn args) = foldMap f args
foldl1 f (InfixPatSyn left right) = left `f` right
foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args
foldr1 f (InfixPatSyn left right) = left `f` right
foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args
#if __GLASGOW_HASKELL__ >= 709
length (InfixPatSyn _ _) = 2
length (PrefixPatSyn args) = Data.List.length args
null (InfixPatSyn _ _) = False
null (PrefixPatSyn args) = Data.List.null args
toList (InfixPatSyn left right) = [left, right]
toList (PrefixPatSyn args) = args
#endif
instance Traversable HsPatSynDetails where
traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
data HsPatSynDir id
= Unidirectional
| ImplicitBidirectional
| ExplicitBidirectional (MatchGroup id (LHsExpr id))
deriving (Typeable)
deriving instance (DataId id) => Data (HsPatSynDir id)