Commit 64035404 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge branch 'master' of http://darcs.haskell.org//ghc

Conflicts:
	compiler/hsSyn/Convert.lhs
	compiler/hsSyn/HsDecls.lhs
parents a44c3d90 bcb59950
......@@ -168,6 +168,9 @@ Wired-in thing => The thing (Id, TyCon) is fully known to the compiler,
All built-in syntax is for wired-in things.
\begin{code}
instance HasOccName Name where
occName = nameOccName
nameUnique :: Name -> Unique
nameOccName :: Name -> OccName
nameModule :: Name -> Module
......
......@@ -54,6 +54,7 @@ module OccName (
mkTupleOcc,
setOccNameSpace,
demoteOccName,
HasOccName(..),
-- ** Derived 'OccName's
isDerivedOccName,
......@@ -334,6 +335,11 @@ demoteOccName :: OccName -> Maybe OccName
demoteOccName (OccName space name) = do
space' <- demoteNameSpace space
return $ OccName space' name
{- | Other names in the compiler add aditional information to an OccName.
This class provides a consistent way to access the underlying OccName. -}
class HasOccName name where
occName :: name -> OccName
\end{code}
......@@ -492,7 +498,7 @@ isDataSymOcc _ = False
-- it is a data constructor or variable or whatever)
isSymOcc :: OccName -> Bool
isSymOcc (OccName DataName s) = isLexConSym s
isSymOcc (OccName TcClsName s) = isLexConSym s
isSymOcc (OccName TcClsName s) = isLexConSym s || isLexVarSym s
isSymOcc (OccName VarName s) = isLexSym s
isSymOcc (OccName TvName s) = isLexSym s
-- Pretty inefficient!
......
......@@ -130,6 +130,10 @@ data RdrName
%************************************************************************
\begin{code}
instance HasOccName RdrName where
occName = rdrNameOcc
rdrNameOcc :: RdrName -> OccName
rdrNameOcc (Qual _ occ) = occ
rdrNameOcc (Unqual occ) = occ
......
-- Cmm representations using Hoopl's Graph CmmNode e x.
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#if __GLASGOW_HASKELL__ >= 703
-- GHC 7.0.1 improved incomplete pattern warnings with GADTs
......
......@@ -1097,8 +1097,16 @@ getTyDescription ty
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
ForAllTy _ ty -> getTyDescription ty
LitTy n -> getTyLitDescription n
}
where
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
getTyLitDescription :: TyLit -> String
getTyLitDescription l =
case l of
NumTyLit n -> show n
StrTyLit n -> show n
\end{code}
......@@ -864,11 +864,18 @@ getTyDescription ty
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
ForAllTy _ ty -> getTyDescription ty
LitTy n -> getTyLitDescription n
}
where
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
getTyLitDescription :: TyLit -> String
getTyLitDescription l =
case l of
NumTyLit n -> show n
StrTyLit n -> show n
--------------------------------------
-- CmmInfoTable-related things
--------------------------------------
......
......@@ -679,6 +679,9 @@ lintType ty@(TyConApp tc tys)
lintType (ForAllTy tv ty)
= do { lintTyBndrKind tv
; addInScopeVar tv (lintType ty) }
lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
\end{code}
......@@ -717,6 +720,13 @@ lint_co_app ty k tys
= lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys
----------------
lintTyLit :: TyLit -> LintM ()
lintTyLit (NumTyLit n)
| n >= 0 = return ()
| otherwise = failWithL msg
where msg = ptext (sLit "Negative type literal:") <+> integer n
lintTyLit (StrTyLit _) = return ()
lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind
-- (lint_app d fun_kind arg_tys)
-- We have an application (f arg_ty1 .. arg_tyn),
......
......@@ -218,11 +218,12 @@ make_ty t = make_ty' t
-- note calls to make_ty so as to expand types recursively
make_ty' :: Type -> C.Ty
make_ty' (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
make_ty' (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
make_ty' (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
make_ty' (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
make_ty' (TyConApp tc ts) = make_tyConApp tc ts
make_ty' (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
make_ty' (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
make_ty' (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
make_ty' (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
make_ty' (TyConApp tc ts) = make_tyConApp tc ts
make_ty' (LitTy {}) = panic "MkExernalCore can't do literal types yet"
-- Newtypes are treated just like any other type constructor; not expanded
-- Reason: predTypeRep does substitution and, while substitution deals
......
......@@ -30,6 +30,7 @@ import TypeRep
import Var
import UniqFM
import Unique( Unique )
import FastString(FastString)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
......@@ -486,7 +487,10 @@ data TypeMap a
, tm_app :: TypeMap (TypeMap a)
, tm_fun :: TypeMap (TypeMap a)
, tm_tc_app :: NameEnv (ListMap TypeMap a)
, tm_forall :: TypeMap (BndrMap a) }
, tm_forall :: TypeMap (BndrMap a)
, tm_tylit :: TyLitMap a
}
instance Outputable a => Outputable (TypeMap a) where
ppr m = text "TypeMap elts" <+> ppr (foldTypeMap (:) [] m)
......@@ -499,7 +503,8 @@ wrapEmptyTypeMap = TM { tm_var = emptyTM
, tm_app = EmptyTM
, tm_fun = EmptyTM
, tm_tc_app = emptyNameEnv
, tm_forall = EmptyTM }
, tm_forall = EmptyTM
, tm_tylit = emptyTyLitMap }
instance TrieMap TypeMap where
type Key TypeMap = Type
......@@ -519,6 +524,7 @@ lkT env ty m
go (AppTy t1 t2) = tm_app >.> lkT env t1 >=> lkT env t2
go (FunTy t1 t2) = tm_fun >.> lkT env t1 >=> lkT env t2
go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys
go (LitTy l) = tm_tylit >.> lkTyLit l
go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv
-----------------
......@@ -534,6 +540,7 @@ xtT env (ForAllTy tv ty) f m = m { tm_forall = tm_forall m |> xtT (extendCME e
|>> xtBndr env tv f }
xtT env (TyConApp tc tys) f m = m { tm_tc_app = tm_tc_app m |> xtNamed tc
|>> xtList (xtT env) tys f }
xtT _ (LitTy l) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f }
fdT :: (a -> b -> b) -> TypeMap a -> b -> b
fdT _ EmptyTM = \z -> z
......@@ -542,6 +549,33 @@ fdT k m = foldTM k (tm_var m)
. foldTM (foldTM k) (tm_fun m)
. foldTM (foldTM k) (tm_tc_app m)
. foldTM (foldTM k) (tm_forall m)
. foldTyLit k (tm_tylit m)
------------------------
data TyLitMap a = TLM { tlm_number :: Map.Map Integer a
, tlm_string :: Map.Map FastString a
}
emptyTyLitMap :: TyLitMap a
emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty }
lkTyLit :: TyLit -> TyLitMap a -> Maybe a
lkTyLit l =
case l of
NumTyLit n -> tlm_number >.> Map.lookup n
StrTyLit n -> tlm_string >.> Map.lookup n
xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a
xtTyLit l f m =
case l of
NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n }
StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n }
foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b
foldTyLit l m = flip (Map.fold l) (tlm_string m)
. flip (Map.fold l) (tlm_number m)
\end{code}
......
......@@ -120,7 +120,7 @@ deSugar hsc_env
else return (binds, hpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
do { let ds_ev_binds = dsEvBinds ev_binds
do { ds_ev_binds <- dsEvBinds ev_binds
; core_prs <- dsTopLHsBinds binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
; (ds_fords, foreign_prs) <- dsForeigns fords
......
......@@ -32,6 +32,7 @@ import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import HscTypes ( MonadThings )
import Literal ( Literal(MachStr) )
import CoreSubst
import MkCore
......@@ -69,6 +70,7 @@ import ErrUtils( MsgDoc )
import Util
import Control.Monad( when )
import MonadUtils
import Control.Monad(liftM)
\end{code}
%************************************************************************
......@@ -112,7 +114,7 @@ dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
, fun_infix = inf })
= do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
; let body' = mkOptTickBox tick body
rhs = dsHsWrapper co_fn (mkLams args body')
; rhs <- dsHsWrapper co_fn (mkLams args body')
; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
return (unitOL (makeCorePair fun False 0 rhs)) }
......@@ -136,9 +138,10 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abe_mono = local, abe_prags = prags } <- export
= do { bind_prs <- ds_lhs_binds binds
; let core_bind = Rec (fromOL bind_prs)
rhs = dsHsWrapper wrap $ -- Usually the identity
; ds_binds <- dsTcEvBinds ev_binds
; rhs <- dsHsWrapper wrap $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
mkCoreLets (dsTcEvBinds ev_binds) $
mkCoreLets ds_binds $
Let core_bind $
Var local
......@@ -159,24 +162,25 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
| (lcl_id, rhs) <- fromOL bind_prs ]
-- Monomorphic recursion possible, hence Rec
locals = map abe_mono exports
tup_expr = mkBigCoreVarTup locals
tup_ty = exprType tup_expr
poly_tup_rhs = mkLams tyvars $ mkLams dicts $
mkCoreLets (dsTcEvBinds ev_binds) $
; ds_binds <- dsTcEvBinds ev_binds
; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
Let core_bind $
tup_expr
locals = map abe_mono exports
; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
= do { tup_id <- newSysLocalDs tup_ty
; let rhs = dsHsWrapper wrap $
; rhs <- dsHsWrapper wrap $
mkLams tyvars $ mkLams dicts $
mkTupleSelector locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
; let global' = (global `setInlinePragma` defaultInlinePragma)
`addIdSpecialisations` rules
......@@ -437,8 +441,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
= putSrcSpanDs loc $
do { let poly_name = idName poly_id
; spec_name <- newLocalName poly_name
; let (bndrs, ds_lhs) = collectBinders (dsHsWrapper spec_co (Var poly_id))
spec_ty = mkPiTypes bndrs (exprType ds_lhs)
; (bndrs, ds_lhs) <- liftM collectBinders
(dsHsWrapper spec_co (Var poly_id))
; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
; case decomposeRuleLhs bndrs ds_lhs of {
Left msg -> do { warnDs msg; return Nothing } ;
Right (final_bndrs, _fn, args) -> do
......@@ -454,8 +459,8 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
final_bndrs args
(mkVarApps (Var spec_id) bndrs)
spec_rhs = dsHsWrapper spec_co poly_rhs
spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
; spec_rhs <- dsHsWrapper spec_co poly_rhs
; let spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
; dflags <- getDynFlags
; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
......@@ -690,28 +695,29 @@ as the old one, but with an Internal name and no IdInfo.
\begin{code}
dsHsWrapper :: HsWrapper -> CoreExpr -> CoreExpr
dsHsWrapper WpHole e = e
dsHsWrapper (WpTyApp ty) e = App e (Type ty)
dsHsWrapper (WpLet ev_binds) e = mkCoreLets (dsTcEvBinds ev_binds) e
dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 (dsHsWrapper c2 e)
dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e)
dsHsWrapper (WpEvLam ev) e = Lam ev e
dsHsWrapper (WpTyLam tv) e = Lam tv e
dsHsWrapper (WpEvApp evtrm) e = App e (dsEvTerm evtrm)
dsHsWrapper :: MonadThings m => HsWrapper -> CoreExpr -> m CoreExpr
dsHsWrapper WpHole e = return e
dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
return (mkCoreLets bs e)
dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e
dsHsWrapper (WpCast co) e = return $ dsTcCoercion co (mkCast e)
dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm)
--------------------------------------
dsTcEvBinds :: TcEvBinds -> [CoreBind]
dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds :: MonadThings m => TcEvBinds -> m [CoreBind]
dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds (EvBinds bs) = dsEvBinds bs
dsEvBinds :: Bag EvBind -> [CoreBind]
dsEvBinds bs = map ds_scc (sccEvBinds bs)
dsEvBinds :: MonadThings m => Bag EvBind -> m [CoreBind]
dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
where
ds_scc (AcyclicSCC (EvBind v r)) = NonRec v (dsEvTerm r)
ds_scc (CyclicSCC bs) = Rec (map ds_pair bs)
ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)
ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs)
ds_pair (EvBind v r) = (v, dsEvTerm r)
ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r)
sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
......@@ -724,19 +730,20 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
---------------------------------------
dsEvTerm :: EvTerm -> CoreExpr
dsEvTerm (EvId v) = Var v
dsEvTerm :: MonadThings m => EvTerm -> m CoreExpr
dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCast v co)
= dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
= return $ dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvKindCast v co)
= dsTcCoercion co $ (\_ -> Var v)
= return $ dsTcCoercion co $ (\_ -> Var v)
dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
dsEvTerm (EvDFunApp df tys vars) = return (Var df `mkTyApps` tys `mkVarApps` vars)
dsEvTerm (EvCoercion co) = return $ dsTcCoercion co mkEqBox
dsEvTerm (EvTupleSel v n)
= ASSERT( isTupleTyCon tc )
return $
Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')]
where
(tc, tys) = splitTyConApp (evVarPred v)
......@@ -744,17 +751,23 @@ dsEvTerm (EvTupleSel v n)
v' = v `setVarType` ty_want
xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after
(tys_before, ty_want:tys_after) = splitAt n tys
dsEvTerm (EvTupleMk vs) = Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
dsEvTerm (EvTupleMk vs) = return $ Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
where dc = tupleCon ConstraintTuple (length vs)
tys = map varType vs
dsEvTerm (EvSuperClass d n)
= Var sc_sel_id `mkTyApps` tys `App` Var d
= return $ Var sc_sel_id `mkTyApps` tys `App` Var d
where
sc_sel_id = classSCSelId cls n -- Zero-indexed
(cls, tys) = getClassPredTys (evVarPred d)
dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
where errorId = rUNTIME_ERROR_ID
litMsg = Lit (MachStr msg)
dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
where
errorId = rUNTIME_ERROR_ID
litMsg = Lit (MachStr msg)
dsEvTerm (EvLit l) =
case l of
EvNum n -> mkIntegerExpr n
EvStr s -> mkStringExprFS s
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
......
......@@ -79,7 +79,8 @@ dsValBinds (ValBindsIn _ _) _ = panic "dsValBinds ValBindsIn"
-------------------------
dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
dsIPBinds (IPBinds ip_binds ev_binds) body
= do { let inner = mkCoreLets (dsTcEvBinds ev_binds) body
= do { ds_binds <- dsTcEvBinds ev_binds
; let inner = mkCoreLets ds_binds body
-- The dict bindings may not be in
-- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds }
......@@ -131,7 +132,8 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body)
body1 binds
; return (mkCoreLets (dsTcEvBinds ev_binds) body2) }
; ds_binds <- dsTcEvBinds ev_binds
; return (mkCoreLets ds_binds body2) }
dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
, fun_tick = tick, fun_infix = inf }) body
......@@ -216,7 +218,7 @@ dsExpr (HsOverLit lit) = dsOverLit lit
dsExpr (HsWrap co_fn e)
= do { e' <- dsExpr e
; let wrapped_e = dsHsWrapper co_fn e'
; wrapped_e <- dsHsWrapper co_fn e'
; warn_id <- woptDs Opt_WarnIdentities
; when warn_id $ warnAboutIdentities e' wrapped_e
; return wrapped_e }
......
......@@ -356,7 +356,7 @@ matchCoercion (var:vars) ty (eqns@(eqn1:_))
; var' <- newUniqueId var (hsPatType pat)
; match_result <- match (var':vars) ty $
map (decomposeFirstPat getCoPat) eqns
; let rhs' = dsHsWrapper co (Var var)
; rhs' <- dsHsWrapper co (Var var)
; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
matchCoercion _ _ _ = panic "matchCoercion"
......
......@@ -32,6 +32,7 @@ import Id
import NameEnv
import SrcLoc
import Outputable
import Control.Monad(liftM)
\end{code}
We are confronted with the first column of patterns in a set of
......@@ -131,18 +132,20 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
-- All members of the group have compatible ConArgPats
match_group arg_vars arg_eqn_prs
= do { let (wraps, eqns') = unzip (map shift arg_eqn_prs)
group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
= do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
; match_result <- match (group_arg_vars ++ vars) ty eqns'
; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
pat_binds = bind, pat_args = args
} : pats }))
= ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets (dsTcEvBinds bind)
, eqn { eqn_pats = conArgPats arg_tys args ++ pats })
= do ds_bind <- dsTcEvBinds bind
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets ds_bind
, eqn { eqn_pats = conArgPats arg_tys args ++ pats }
)
shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
-- Choose the right arg_vars in the right order for this group
......
......@@ -290,7 +290,6 @@ cvt_tyinst_hdr cxt tc tys
; tys' <- mapM cvtType tys
; return (cxt', tc', mkHsBSig tys') }
-------------------------------------------------------------------
-- Partitioning declarations
-------------------------------------------------------------------
......
......@@ -623,7 +623,7 @@ pp_vanilla_decl_head :: OutputableBndr name
-> HsContext name
-> SDoc
pp_vanilla_decl_head thing tyvars context
= hsep [pprHsContext context, ppr thing, interppSP tyvars]
= hsep [pprHsContext context, pprPrefixOcc (unLoc thing), interppSP tyvars]
pp_fam_inst_head :: OutputableBndr name
=> Located name
......@@ -631,7 +631,7 @@ pp_fam_inst_head :: OutputableBndr name
-> HsContext name
-> SDoc
pp_fam_inst_head thing (HsBSig typats _) context -- explicit type patterns
= hsep [ ptext (sLit "instancs"), pprHsContext context, ppr thing
= hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing)
, hsep (map (pprParendHsType.unLoc) typats)]
pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
......
......@@ -12,6 +12,7 @@ module HsImpExp where
import Module ( ModuleName )
import HsDoc ( HsDocString )
import OccName ( HasOccName(..), isTcOcc, isSymOcc )
import Outputable
import FastString
......@@ -57,7 +58,7 @@ simpleImportDecl mn = ImportDecl {
\end{code}
\begin{code}
instance (OutputableBndr name) => Outputable (ImportDecl name) where
instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) where
ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg
, ideclSource = from, ideclSafe = safe
, ideclQualified = qual, ideclImplicit = implicit
......@@ -134,12 +135,20 @@ ieNames (IEDocNamed _ ) = []
\end{code}
\begin{code}
instance (OutputableBndr name, Outputable name) => Outputable (IE name) where
pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc
pprImpExp name = type_pref <+> pprPrefixOcc name
where
occ = occName name
type_pref | isTcOcc occ && isSymOcc occ = ptext (sLit "type")
| otherwise = empty
instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
ppr (IEVar var) = pprPrefixOcc var
ppr (IEThingAbs thing) = ppr thing
ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"]
ppr (IEThingAbs thing) = pprImpExp thing
ppr (IEThingAll thing) = hcat [pprImpExp thing, text "(..)"]
ppr (IEThingWith thing withs)
= pprPrefixOcc thing <> parens (fsep (punctuate comma (map pprPrefixOcc withs)))
= pprImpExp thing <> parens (fsep (punctuate comma (map pprImpExp withs)))
ppr (IEModuleContents mod')
= ptext (sLit "module") <+> ppr mod'
ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">")
......
......@@ -46,6 +46,7 @@ import HsUtils
import HsDoc
-- others:
import OccName ( HasOccName )
import IfaceSyn ( IfaceBinding )
import Outputable
import SrcLoc
......@@ -97,7 +98,7 @@ data HsExtCore name -- Read from Foo.hcr
instance Outputable Char where
ppr c = text [c]
instance (OutputableBndr name)
instance (OutputableBndr name, HasOccName name)
=> Outputable (HsModule name) where
ppr (HsModule Nothing _ imports decls _ mbDoc)
......
......@@ -22,6 +22,7 @@ module HsTypes (
HsContext, LHsContext,
HsQuasiQuote(..),
HsTyWrapper(..),
HsTyLit(..),
LBangType, BangType, HsBang(..),
getBangType, getBangStrictness,
......@@ -212,9 +213,17 @@ data HsType name
[PostTcKind] -- See Note [Promoted lists and tuples]
[LHsType name]
| HsTyLit HsTyLit -- A promoted numeric literal.
| HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output
deriving (Data, Typeable)
data HsTyLit
= HsNumTy Integer
| HsStrTy FastString
deriving (Data, Typeable)
data HsTyWrapper
= WpKiApps [Kind] -- kind instantiation: [] k1 k2 .. kn
deriving (Data, Typeable)
......@@ -475,6 +484,9 @@ splitHsFunType other = ([], other)
instance (OutputableBndr name) => Outputable (HsType name) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
instance (Outputable sig) => Outputable (HsBndrSig sig) where
ppr (HsBSig ty _) = ppr ty
......@@ -576,6 +588,7 @@ ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
ppr_mono_ty _ (HsTyLit t) = ppr_tylit t
ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty)
= ppr_mono_ty ctxt_prec ty
......@@ -623,6 +636,11 @@ ppr_fun_ty ctxt_prec ty1 ty2
in