Commit 09015be8 authored by dreixel's avatar dreixel

New kind-polymorphic core

This big patch implements a kind-polymorphic core for GHC. The current
implementation focuses on making sure that all kind-monomorphic programs still
work in the new core; it is not yet guaranteed that kind-polymorphic programs
(using the new -XPolyKinds flag) will work.

For more information, see http://haskell.org/haskellwiki/GHC/Kinds
parent fd742437
......@@ -1024,7 +1024,7 @@ voidArgId -- :: State# RealWorld
coercionTokenId :: Id -- :: () ~ ()
coercionTokenId -- Used to replace Coercion terms when we go to STG
= pcMiscPrelId coercionTokenName
(mkTyConApp eqPrimTyCon [unitTy, unitTy])
(mkTyConApp eqPrimTyCon [liftedTypeKind, unitTy, unitTy])
noCafIdInfo
\end{code}
......
......@@ -53,6 +53,7 @@ module OccName (
mkDFunOcc,
mkTupleOcc,
setOccNameSpace,
demoteOccName,
-- ** Derived 'OccName's
isDerivedOccName,
......@@ -204,8 +205,35 @@ pprNameSpaceBrief DataName = char 'd'
pprNameSpaceBrief VarName = char 'v'
pprNameSpaceBrief TvName = ptext (sLit "tv")
pprNameSpaceBrief TcClsName = ptext (sLit "tc")
-- demoteNameSpace lowers the NameSpace if possible. We can not know
-- in advance, since a TvName can appear in an HsTyVar.
-- see Note [Demotion]
demoteNameSpace :: NameSpace -> Maybe NameSpace
demoteNameSpace VarName = Nothing
demoteNameSpace DataName = Nothing
demoteNameSpace TvName = Nothing
demoteNameSpace TcClsName = Just DataName
\end{code}
Note [Demotion]
~~~~~~~~~~~~~~~
When the user writes:
data Nat = Zero | Succ Nat
foo :: f Zero -> Int
'Zero' in the type signature of 'foo' is parsed as:
HsTyVar ("Zero", TcClsName)
When the renamer hits this occurence of 'Zero' it's going to realise
that it's not in scope. But because it is renaming a type, it knows
that 'Zero' might be a promoted data constructor, so it will demote
its namespace to DataName and do a second lookup.
The final result (after the renamer) will be:
HsTyVar ("Zero", DataName)
%************************************************************************
%* *
......@@ -316,6 +344,13 @@ mkClsOcc = mkOccName clsName
mkClsOccFS :: FastString -> OccName
mkClsOccFS = mkOccNameFS clsName
-- demoteOccName lowers the Namespace of OccName.
-- see Note [Demotion]
demoteOccName :: OccName -> Maybe OccName
demoteOccName (OccName space name) = do
space' <- demoteNameSpace space
return $ OccName space' name
\end{code}
......
......@@ -40,7 +40,7 @@ module RdrName (
nameRdrName, getRdrName,
-- ** Destruction
rdrNameOcc, rdrNameSpace, setRdrNameSpace,
rdrNameOcc, rdrNameSpace, setRdrNameSpace, demoteRdrName,
isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,
isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,
......@@ -159,6 +159,14 @@ setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
setRdrNameSpace (Exact n) ns = ASSERT( isExternalName n )
Orig (nameModule n)
(setOccNameSpace ns (nameOccName n))
-- demoteRdrName lowers the NameSpace of RdrName.
-- see Note [Demotion] in OccName
demoteRdrName :: RdrName -> Maybe RdrName
demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ)
demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)
demoteRdrName (Orig _ _) = panic "demoteRdrName"
demoteRdrName (Exact _) = panic "demoteRdrName"
\end{code}
\begin{code}
......
......@@ -39,7 +39,7 @@
module Var (
-- * The main data type and synonyms
Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId,
Var, TyVar, CoVar, Id, KindVar, DictId, DFunId, EvVar, EqVar, EvId, IpId,
-- ** Taking 'Var's apart
varName, varUnique, varType,
......@@ -60,20 +60,21 @@ module Var (
mustHaveLocalBinding,
-- ** Constructing 'TyVar's
mkTyVar, mkTcTyVar,
mkTyVar, mkTcTyVar, mkKindVar,
-- ** Taking 'TyVar's apart
tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
-- ** Modifying 'TyVar's
setTyVarName, setTyVarUnique, setTyVarKind
setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind,
updateTyVarKindM
) where
#include "HsVersions.h"
#include "Typeable.h"
import {-# SOURCE #-} TypeRep( Type, Kind )
import {-# SOURCE #-} TypeRep( Type, Kind, SuperKind )
import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails )
import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails )
......@@ -98,7 +99,10 @@ import Data.Data
\begin{code}
type Id = Var -- A term-level identifier
type TyVar = Var
type TyVar = Var -- Type *or* kind variable
type KindVar = Var -- Definitely a kind variable
-- See Note [Kind and type variables]
-- See Note [Evidence: EvIds and CoVars]
type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar
......@@ -125,6 +129,16 @@ Note [Evidence: EvIds and CoVars]
* Only CoVars can occur in Coercions (but NB the LCoercion hack; see
Note [LCoercions] in Coercion).
Note [Kind and type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Before kind polymorphism, TyVar were used to mean type variables. Now
they are use to mean kind *or* type variables. KindVar is used when we
know for sure that it is a kind variable. In future, we might want to
go over the whole compiler code to use:
- KiTyVar to mean kind or type variables
- TyVar to mean type variables only
- KindVar to mean kind variables
%************************************************************************
%* *
......@@ -142,7 +156,8 @@ in its @VarDetails@.
-- | Essentially a typed 'Name', that may also contain some additional information
-- about the 'Var' and it's use sites.
data Var
= TyVar {
= TyVar { -- type and kind variables
-- see Note [Kind and type variables]
varName :: !Name,
realUnique :: FastInt, -- Key for fast comparison
-- Identical to the Unique in the name,
......@@ -195,7 +210,8 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds
\begin{code}
instance Outputable Var where
ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
ppr var = ifPprDebug (text "(") <+> ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
<+> ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")")
ppr_debug :: Var -> SDoc
ppr_debug (TyVar {}) = ptext (sLit "tv")
......@@ -255,7 +271,7 @@ setVarType id ty = id { varType = ty }
%************************************************************************
%* *
\subsection{Type variables}
\subsection{Type and kind variables}
%* *
%************************************************************************
......@@ -274,6 +290,14 @@ setTyVarName = setVarName
setTyVarKind :: TyVar -> Kind -> TyVar
setTyVarKind tv k = tv {varType = k}
updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar
updateTyVarKind update tv = tv {varType = update (tyVarKind tv)}
updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar
updateTyVarKindM update tv
= do { k' <- update (tyVarKind tv)
; return $ tv {varType = k'} }
\end{code}
\begin{code}
......@@ -298,6 +322,15 @@ tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
setTcTyVarDetails tv details = tv { tc_tv_details = details }
mkKindVar :: Name -> SuperKind -> KindVar
-- mkKindVar take a SuperKind as argument because we don't have access
-- to tySuperKind here.
mkKindVar name kind = TyVar
{ varName = name
, realUnique = getKeyFastInt (nameUnique name)
, varType = kind }
\end{code}
%************************************************************************
......
This diff is collapsed.
......@@ -67,6 +67,7 @@ import Util
import Pair
import Data.Word
import Data.Bits
import Data.List ( mapAccumL )
\end{code}
......@@ -1064,9 +1065,10 @@ dataConInstPat :: [FastString] -- A long enough list of FSs to use for
--
-- where the double-primed variables are created with the FastStrings and
-- Uniques given as fss and us
dataConInstPat fss uniqs con inst_tys
= (ex_bndrs, arg_ids)
where
dataConInstPat fss uniqs con inst_tys
= ASSERT( univ_tvs `equalLength` inst_tys )
(ex_bndrs, arg_ids)
where
univ_tvs = dataConUnivTyVars con
ex_tvs = dataConExTyVars con
arg_tys = dataConRepArgTys con
......@@ -1077,19 +1079,25 @@ dataConInstPat fss uniqs con inst_tys
(ex_uniqs, id_uniqs) = splitAt n_ex uniqs
(ex_fss, id_fss) = splitAt n_ex fss
-- Make existential type variables
ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
mk_ex_var uniq fs var = mkTyVar new_name kind
-- Make the instantiating substitution for universals
univ_subst = zipOpenTvSubst univ_tvs inst_tys
-- Make existential type variables, applyingn and extending the substitution
(full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst
(zip3 ex_tvs ex_fss ex_uniqs)
mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar)
mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubst subst tv (mkTyVarTy new_tv)
, new_tv)
where
new_tv = mkTyVar new_name kind
new_name = mkSysTvName uniq fs
kind = tyVarKind var
-- Make the instantiating substitution
subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
kind = Type.substTy subst (tyVarKind tv)
-- Make value vars, instantiating types
mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan
arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq
(Type.substTy full_subst ty) noSrcSpan
\end{code}
%************************************************************************
......
......@@ -288,8 +288,10 @@ mkIPUnbox ipx = Var x `Cast` mkAxInstCo (ipCoAxiom ip) [ty]
\begin{code}
mkEqBox :: Coercion -> CoreExpr
mkEqBox co = Var (dataConWorkId eqBoxDataCon) `mkTyApps` [ty1, ty2] `App` Coercion co
mkEqBox co = ASSERT( typeKind ty2 `eqKind` k )
Var (dataConWorkId eqBoxDataCon) `mkTyApps` [k, ty1, ty2] `App` Coercion co
where Pair ty1 ty2 = coercionKind co
k = typeKind ty1
\end{code}
......
......@@ -23,6 +23,7 @@ import TyCon
-- import Class
import TypeRep
import Type
import Kind
import PprExternalCore () -- Instances
import DataCon
import Coercion
......
......@@ -28,6 +28,7 @@ import Demand
import DataCon
import TyCon
import Type
import Kind
import Coercion
import StaticFlags
import BasicTypes
......
......@@ -86,7 +86,6 @@ deSugar hsc_env
tcg_rules = rules,
tcg_vects = vects,
tcg_tcs = tcs,
tcg_clss = clss,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
tcg_hpc = other_hpc_info })
......@@ -184,7 +183,6 @@ deSugar hsc_env
mg_warns = warns,
mg_anns = anns,
mg_tcs = tcs,
mg_clss = clss,
mg_insts = insts,
mg_fam_insts = fam_insts,
mg_inst_env = inst_env,
......
......@@ -53,6 +53,7 @@ import NameEnv
import TcType
import TyCon
import TysWiredIn
import TysPrim ( liftedTypeKindTyConName )
import CoreSyn
import MkCore
import CoreUtils
......@@ -81,7 +82,7 @@ dsBracket brack splices
where
new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 }
do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
......@@ -598,7 +599,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
-> Core TH.Name -> DsM (Core TH.TyVarBndr)
repTyVarBndrWithKind (L _ (UserTyVar {})) nm
= repPlainTV nm
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
repTyVarBndrWithKind (L _ (KindedTyVar _ ki _)) nm
= repKind ki >>= repKindedTV nm
-- represent a type context
......@@ -684,7 +685,7 @@ repTy (HsTupleTy HsUnboxedTuple tys) = do
tys1 <- repLTys tys
tcon <- repUnboxedTupleTyCon (length tys)
repTapps tcon tys1
repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
`nlHsAppTy` ty2)
repTy (HsParTy t) = repLTy t
repTy (HsKindSig t k) = do
......@@ -696,17 +697,16 @@ repTy ty = notHandled "Exotic form of type" (ppr ty)
-- represent a kind
--
repKind :: Kind -> DsM (Core TH.Kind)
repKind :: LHsKind Name -> DsM (Core TH.Kind)
repKind ki
= do { let (kis, ki') = splitKindFunTys ki
= do { let (kis, ki') = splitHsFunType ki
; kis_rep <- mapM repKind kis
; ki'_rep <- repNonArrowKind ki'
; foldrM repArrowK ki'_rep kis_rep
}
where
repNonArrowKind k | isLiftedTypeKind k = repStarK
| otherwise = notHandled "Exotic form of kind"
(ppr k)
repNonArrowKind (L _ (HsTyVar name)) | name == liftedTypeKindTyConName = repStarK
repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
-----------------------------------------------------------------------------
-- Splices
......
......@@ -45,6 +45,7 @@ import Var
import TcRnMonad
import TcType
import TcMType
import TcHsSyn ( mkZonkTcTyVar )
import TcUnify
import TcEnv
......@@ -1130,7 +1131,7 @@ zonkTerm = foldTermM (TermFoldM
zonkRttiType :: TcType -> TcM Type
-- Zonk the type, replacing any unbound Meta tyvars
-- by skolems, safely out of Meta-tyvar-land
zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta)
zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta mkTyVarTy)
where
zonk_unbound_meta tv
= ASSERT( isTcTyVar tv )
......
......@@ -27,7 +27,6 @@ import qualified OccName
import OccName
import SrcLoc
import Type
import Coercion
import TysWiredIn
import BasicTypes as Hs
import ForeignCall
......@@ -204,7 +203,7 @@ cvtDec (ForeignD ford)
cvtDec (FamilyD flav tc tvs kind)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; let kind' = fmap cvtKind kind
; kind' <- cvtMaybeKind kind
; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') }
where
cvtFamFlavour TypeFam = TypeFamily
......@@ -785,7 +784,8 @@ cvt_tv (TH.PlainTV nm)
}
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
; returnL $ KindedTyVar nm' (cvtKind ki)
; ki' <- cvtKind ki
; returnL $ KindedTyVar nm' ki' placeHolderKind
}
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
......@@ -842,7 +842,8 @@ cvtType ty
SigT ty ki
-> do { ty' <- cvtType ty
; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
; ki' <- cvtKind ki
; mk_apps (HsKindSig ty' ki') tys'
}
_ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
......@@ -859,9 +860,16 @@ split_ty_app ty = go ty []
go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
go f as = return (f,as)
cvtKind :: TH.Kind -> Type.Kind
cvtKind StarK = liftedTypeKind
cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
cvtKind StarK = returnL (HsTyVar (getRdrName liftedTypeKindTyCon))
cvtKind (ArrowK k1 k2) = do
k1' <- cvtKind k1
k2' <- cvtKind k2
returnL (HsFunTy k1' k2')
cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
cvtMaybeKind Nothing = return Nothing
cvtMaybeKind (Just ki) = cvtKind ki >>= return . Just
-----------------------------------------------------------
......
......@@ -23,6 +23,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat ( LPat )
import HsLit
import HsTypes
import PprCore ()
import CoreSyn
......@@ -461,9 +462,9 @@ data HsWrapper
| WpEvLam EvVar -- \d. [] the 'd' is an evidence variable
| WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint
-- Type abstraction and application
| WpTyLam TyVar -- \a. [] the 'a' is a type variable (not coercion var)
| WpTyApp Type -- [] t the 't' is a type (not coercion)
-- Kind and Type abstraction and application
| WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var)
| WpTyApp KindOrType -- [] t the 't' is a type (not coercion)
| WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings,
......
......@@ -14,7 +14,7 @@ module HsDecls (
-- * Toplevel declarations
HsDecl(..), LHsDecl,
-- ** Class or type declarations
TyClDecl(..), LTyClDecl,
TyClDecl(..), LTyClDecl, TyClGroup,
isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
isFamInstDecl, tcdName, tyClDeclTyVars,
countTyClDecls,
......@@ -63,7 +63,6 @@ import HsDoc
import TyCon
import NameSet
import Name
import {- Kind parts of -} Type
import BasicTypes
import Coercion
import ForeignCall
......@@ -431,6 +430,8 @@ Interface file code:
-- In both cases, 'tcdVars' collects all variables we need to quantify over.
type LTyClDecl name = Located (TyClDecl name)
type TyClGroup name = [LTyClDecl name] -- this is used in TcTyClsDecls to represent
-- strongly connected components of decls
-- | A type or class declaration.
data TyClDecl name
......@@ -444,7 +445,7 @@ data TyClDecl name
TyFamily { tcdFlavour:: FamilyFlavour, -- type or data
tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
tcdKind :: Maybe Kind -- result kind
tcdKind :: Maybe (LHsKind name) -- result kind
}
......@@ -461,7 +462,7 @@ data TyClDecl name
tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns.
-- See Note [tcdTyVars and tcdTyPats]
tcdKindSig:: Maybe Kind,
tcdKindSig:: Maybe (LHsKind name),
-- ^ Optional kind signature.
--
-- @(Just k)@ for a GADT-style @data@, or @data
......@@ -535,14 +536,18 @@ tcdTyPats = Just tys
This is a data/type family instance declaration
tcdTyVars are fv(tys)
Eg class C a b where
type F a x :: *
instance D p s => C (p,q) [r] where
type F (p,q) x = p -> x
The tcdTyVars of the F instance decl are {p,q,x},
i.e. not including s, nor r
(and indeed neither s nor should be mentioned
on the RHS of the F instance decl; Trac #5515)
Eg class C s t where
type F t p :: *
instance C w (a,b) where
type F (a,b) x = x->a
The tcdTyVars of the F decl are {a,b,x}, even though the F decl
is nested inside the 'instance' decl.
However after the renamer, the uniques will match up:
instance C w7 (a8,b9) where
type F (a8,b9) x10 = x10->a8
so that we can compare the type patter in the 'instance' decl and
in the associated 'type' decl
------------------------------
Simple classifiers
......@@ -631,7 +636,7 @@ instance OutputableBndr name
pp_kind = case mb_kind of
Nothing -> empty
Just kind -> dcolon <+> pprKind kind
Just kind -> dcolon <+> ppr kind
ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
tcdSynRhs = mono_ty})
......@@ -653,7 +658,7 @@ instance OutputableBndr name
derivings
where
ppr_sigx Nothing = empty
ppr_sigx (Just kind) = dcolon <+> pprKind kind
ppr_sigx (Just kind) = dcolon <+> ppr kind
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFDs = fds,
......
......@@ -1197,7 +1197,8 @@ data HsBracket id = ExpBr (LHsExpr id) -- [| expr |]
| DecBrL [LHsDecl id] -- [d| decls |]; result of parser
| DecBrG (HsGroup id) -- [d| decls |]; result of renamer
| TypBr (LHsType id) -- [t| type |]
| VarBr id -- 'x, ''T
| VarBr Bool id -- True: 'x, False: ''T
-- (The Bool flag is used only in pprHsBracket)
deriving (Data, Typeable)
instance OutputableBndr id => Outputable (HsBracket id) where
......@@ -1210,11 +1211,8 @@ pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
pprHsBracket (VarBr n) = char '\'' <> ppr n
-- Infelicity: can't show ' vs '', because
-- we can't ask n what its OccName is, because the
-- pretty-printer for HsExpr doesn't ask for NamedThings
-- But the pretty-printer for names will show the OccName class
pprHsBracket (VarBr True n) = char '\'' <> ppr n
pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n
thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
......
\begin{code}
{-# LANGUAGE KindSignatures #-}
{-# 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
......@@ -13,11 +14,12 @@ import Outputable ( SDoc, OutputableBndr )
import {-# SOURCE #-} HsPat ( LPat )
import Data.Data
data HsExpr i
data HsSplice i
data MatchGroup a
data GRHSs a
-- IA0_NOTE: We need kind annotations because of kind polymorphism
data HsExpr (i :: *)
data HsSplice (i :: *)
data MatchGroup (a :: *)
data GRHSs (a :: *)
instance Typeable1 HsSplice
instance Data i => Data (HsSplice i)
......
......@@ -20,8 +20,7 @@ module HsLit where
import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
import BasicTypes ( FractionalLit(..) )
import HsTypes ( PostTcType )
import Type ( Type )
import Type ( Type, Kind )
import Outputable
import FastString
......@@ -29,6 +28,26 @@ import Data.Data
\end{code}
%************************************************************************
%* *
\subsection{Annotating the syntax}
%* *
%************************************************************************
\begin{code}
type PostTcKind = Kind
type PostTcType = Type -- Used for slots in the abstract syntax
-- where we want to keep slot for a type
-- to be added by the type checker...but
-- before typechecking it's just bogus
placeHolderType :: PostTcType -- Used before typechecking
placeHolderType = panic "Evaluated the place holder for a PostTcType"
placeHolderKind :: PostTcKind -- Used before typechecking
placeHolderKind = panic "Evaluated the place holder for a PostTcKind"
\end{code}
%************************************************************************
%* *
\subsection[HsLit]{Literals}
......
\begin{code}
{-# LANGUAGE KindSignatures #-}
module HsPat where
import SrcLoc( Located )
import Data.Data
data Pat i
-- IA0_NOTE: We need kind annotation because of kind polymorphism.
data Pat (i :: *)
type LPat i = Located (Pat i)
instance Typeable1 Pat
......
This diff is collapsed.
......@@ -1006,11 +1006,31 @@ instance Binary IfaceType where
put_ bh ah
-- Simple compression for common cases of TyConApp
put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 4; put_ bh k }
put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 5; put_ bh tc; put_ bh tys }
put_ bh (IfaceTyConApp tc tys) = do { putByte bh 6; put_ bh tc; put_ bh tys }
put_ bh (IfaceCoConApp cc tys) = do { putByte bh 7; put_ bh cc; put_ bh tys }
put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
-- Unit tuple and pairs
put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) = putByte bh 10
put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2])
= do { putByte bh 11; put_ bh t1; put_ bh t2 }
-- Kind cases
put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
put_ bh (IfaceTyConApp IfaceConstraintKindTc []) = putByte bh 17
put_ bh (IfaceTyConApp IfaceSuperKindTc []) = putByte bh 18
put_ bh (IfaceCoConApp cc tys)
= do { putByte bh 19; put_ bh cc; put_ bh tys }
-- Generic cases
put_ bh (IfaceTyConApp (IfaceTc tc) tys)
= do { putByte bh 20; put_ bh tc; put_ bh tys }
put_ bh (IfaceTyConApp tc tys)
= do { putByte bh 21; put_ bh tc; put_ bh tys }
get bh = do
h <- getByte bh
......@@ -1026,20 +1046,70 @@ instance Binary IfaceType where
3 -> do ag <- get bh
ah <- get bh
return (IfaceFunTy ag ah)
4 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
5 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
6 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
_ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) }
-- Now the special cases for TyConApp
6 -> return (IfaceTyConApp IfaceIntTc [])
7 -> return (IfaceTyConApp IfaceCharTc [])
8 -> return (IfaceTyConApp IfaceBoolTc [])
9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
10 -> return (IfaceTyConApp (IfaceTupTc BoxedTuple 0) [])
11 -> do { t1 <- get bh; t2 <- get bh
; return (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) }
12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])