import {-# SOURCE #-} HsPat ( LPat )
import HsTypes ( LHsType, PostTcType )
-import Type ( Type )
+import PprCore ( {- instances -} )
+import Coercion ( Coercion )
+import Type ( Type, pprParendType )
import Name ( Name )
import NameSet ( NameSet, elemNameSet )
import BasicTypes ( IPName, RecFlag(..), InlineSpec(..), Fixity )
%************************************************************************
\begin{code}
--- A Coercion is an expression with a hole in it
+-- A ExprCoFn 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
+
+ | CoCompose ExprCoFn ExprCoFn -- (\a1..an. []) `CoCompose` (\x1..xn. [])
+ -- = (\a1..an \x1..xn. [])
+
+ | ExprCoFn Coercion -- A cast: [] `cast` co
+ -- Guaranteedn not the identity coercion
+
+ -- Non-empty list in all of these, so that the identity coercion
+ -- is always exactly CoHole, not, say, (CoTyLams [])
+ | CoApps [Var] -- [] x1 .. xn; the xi are dicts or coercions
+ | CoTyApps [Type] -- [] t1 .. tn
+ | CoLams [Id] -- \x1..xn. []; the xi are dicts or coercions
+ | CoTyLams [TyVar] -- \a1..an. []
+ | CoLet (LHsBinds Id) -- Would be nicer to be core bindings
+
+instance Outputable ExprCoFn where
+ ppr CoHole = ptext SLIT("<>")
+ ppr (ExprCoFn co) = ppr co
+ ppr (CoApps ids) = ppr CoHole <+> interppSP ids
+ ppr (CoTyApps tys) = ppr CoHole <+> hsep (map pprParendType tys)
+ ppr (CoTyLams tvs) = sep [ptext SLIT("/\\") <> hsep (map (pprBndr LambdaBind) tvs),
+ ptext SLIT("->") <+> ppr CoHole]
+ ppr (CoLams ids) = sep [ptext SLIT("\\") <> hsep (map (pprBndr LambdaBind) ids),
+ ptext SLIT("->") <+> ppr CoHole]
+ ppr (CoLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds),
+ ppr CoHole]
+ ppr (CoCompose co1 co2) = sep [ppr co1, ptext SLIT("<.>"), ppr co2]
(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
-(<.>) = CoCompose
+CoHole <.> c = c
+c <.> CoHole = c
+c1 <.> c2 = c1 `CoCompose` c2
idCoercion :: ExprCoFn
idCoercion = CoHole
import HsImpExp ( pprHsVar )
import HsTypes
import NameSet ( NameSet )
-import HscTypes ( DeprecTxt )
import CoreSyn ( RuleName )
-import Kind ( Kind, pprKind )
-import BasicTypes ( Activation(..) )
+import {- Kind parts of -} Type ( Kind, pprKind )
+import BasicTypes ( Activation(..), DeprecTxt )
import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety,
CExportSpec(..), CLabelString )
-- others:
-import FunDeps ( pprFundeps )
-import Class ( FunDep )
+import Class ( FunDep, pprFundeps )
import Outputable
import Util ( count )
import SrcLoc ( Located(..), unLoc, noLoc )
Everything from here on appears only in typechecker output.
\begin{code}
- | TyLam -- TRANSLATION
- [TyVar]
- (LHsExpr id)
- | TyApp -- TRANSLATION
- (LHsExpr id) -- generated by Spec
- [Type]
-
- -- DictLam and DictApp are "inverses"
- | DictLam
- [id]
- (LHsExpr id)
- | DictApp
- (LHsExpr id)
- [id]
-
| HsCoerce ExprCoFn -- TRANSLATION
(HsExpr id)
ppr_expr (HsSCC lbl expr)
= sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ]
-ppr_expr (TyLam tyvars expr)
- = hang (hsep [ptext SLIT("/\\"),
- hsep (map (pprBndr LambdaBind) tyvars),
- ptext SLIT("->")])
- 4 (ppr_lexpr expr)
-
-ppr_expr (TyApp expr [ty])
- = hang (ppr_lexpr expr) 4 (pprParendType ty)
-
-ppr_expr (TyApp expr tys)
- = hang (ppr_lexpr expr)
- 4 (brackets (interpp'SP tys))
-
-ppr_expr (DictLam dictvars expr)
- = hang (hsep [ptext SLIT("\\{-dict-}"),
- hsep (map (pprBndr LambdaBind) dictvars),
- ptext SLIT("->")])
- 4 (ppr_lexpr expr)
-
-ppr_expr (DictApp expr [dname])
- = hang (ppr_lexpr expr) 4 (ppr dname)
-
-ppr_expr (DictApp expr dnames)
- = hang (ppr_lexpr expr)
- 4 (brackets (interpp'SP dnames))
-
-ppr_expr (HsCoerce co_fn e) = ppr_expr e
+ppr_expr (HsCoerce co_fn e)
+ = ppr_expr e <+> ptext SLIT("`cast`") <+> ppr co_fn
ppr_expr (HsType id) = ppr id
\begin{code}
module HsPat (
- Pat(..), InPat, OutPat, LPat,
+ Pat(..), InPat, OutPat, LPat,
HsConDetails(..), hsConArgs,
- mkPrefixConPat, mkCharLitPat, mkNilPat,
+ mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat,
isBangHsBind,
patsAreAllCons, isConPat, isSigPat, isWildPat,
import {-# SOURCE #-} HsExpr ( SyntaxExpr )
-- friends:
-import HsBinds ( DictBinds, HsBind(..), emptyLHsBinds, pprLHsBinds )
+import HsBinds ( DictBinds, HsBind(..), ExprCoFn, isIdCoercion, emptyLHsBinds, pprLHsBinds )
import HsLit ( HsLit(HsCharPrim), HsOverLit )
import HsTypes ( LHsType, PostTcType )
import BasicTypes ( Boxity, tupleParens )
| ConPatIn (Located id)
(HsConDetails id (LPat id))
- | ConPatOut (Located DataCon)
- [TyVar] -- Existentially bound type variables
- [id] -- Ditto dictionaries
- (DictBinds id) -- Bindings involving those dictionaries
- (HsConDetails id (LPat id))
- Type -- The type of the pattern
+ | ConPatOut {
+ pat_con :: Located DataCon,
+ pat_tvs :: [TyVar], -- Existentially bound type variables
+ -- including any bound coercion variables
+ pat_dicts :: [id], -- Ditto dictionaries
+ pat_binds :: DictBinds id, -- Bindings involving those dictionaries
+ pat_args :: HsConDetails id (LPat id),
+ pat_ty :: Type -- The type of the pattern
+ }
------------ Literal and n+k patterns ---------------
| LitPat HsLit -- Used for *non-overloaded* literal patterns:
| DictPat -- Used when destructing Dictionaries with an explicit case
[id] -- superclass dicts
[id] -- methods
+
+ ------------ Pattern coercions (translation only) ---------------
+ | CoPat ExprCoFn -- If co::t1 -> t2, p::t2,
+ -- then (CoPat co p) :: t1
+ (Pat id) -- No nested location reqd
+ Type
\end{code}
HsConDetails is use both for patterns and for data type declarations
pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats)
pprPat (ConPatIn con details) = pprUserCon con details
-pprPat (ConPatOut con tvs dicts binds details _)
+pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
+ pat_binds = binds, pat_args = details })
= getPprStyle $ \ sty -> -- Tiresome; in TcBinds.tcRhs we print out a
if debugStyle sty then -- typechecked Pat in an error message,
-- and we want to make sure it prints nicely
pprPat (NPat l (Just _) _ _) = char '-' <> ppr l
pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
+pprPat (CoPat co pat _) = parens (ppr co) <+> ptext SLIT("`cast`") <+> ppr pat
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (DictPat ds ms) = parens (sep [ptext SLIT("{-dict-}"),
\begin{code}
mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
-- Make a vanilla Prefix constructor pattern
-mkPrefixConPat dc pats ty = noLoc $ ConPatOut (noLoc dc) [] [] emptyLHsBinds (PrefixCon pats) ty
+mkPrefixConPat dc pats ty
+ = noLoc $ ConPatOut { pat_con = noLoc dc, pat_tvs = [], pat_dicts = [],
+ pat_binds = emptyLHsBinds, pat_args = PrefixCon pats,
+ pat_ty = ty }
mkNilPat :: Type -> OutPat id
mkNilPat ty = mkPrefixConPat nilDataCon [] ty
mkCharLitPat :: Char -> OutPat id
mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy
+
+mkCoPat :: ExprCoFn -> OutPat id -> Type -> OutPat id
+mkCoPat co lpat@(L loc pat) ty
+ | isIdCoercion co = lpat
+ | otherwise = L loc (CoPat co pat ty)
\end{code}
patsAreAllCons :: [Pat id] -> Bool
patsAreAllCons pat_list = all isConPat pat_list
-isConPat (AsPat _ pat) = isConPat (unLoc pat)
-isConPat (ConPatIn _ _) = True
-isConPat (ConPatOut _ _ _ _ _ _) = True
-isConPat (ListPat _ _) = True
-isConPat (PArrPat _ _) = True
-isConPat (TuplePat _ _ _) = True
-isConPat (DictPat ds ms) = (length ds + length ms) > 1
-isConPat other = False
+isConPat (AsPat _ pat) = isConPat (unLoc pat)
+isConPat (ConPatIn {}) = True
+isConPat (ConPatOut {}) = True
+isConPat (ListPat {}) = True
+isConPat (PArrPat {}) = True
+isConPat (TuplePat {}) = True
+isConPat (DictPat ds ms) = (length ds + length ms) > 1
+isConPat other = False
isSigPat (SigPatIn _ _) = True
isSigPat (SigPatOut _ _) = True
go1 (VarPatOut _ _) = True
go1 (LazyPat pat) = True
go1 (BangPat pat) = go pat
+ go1 (CoPat _ pat _) = go1 pat
go1 (ParPat pat) = go pat
go1 (AsPat _ pat) = go pat
go1 (SigPatIn pat _) = go pat
go1 (PArrPat pats _) = False -- ?
go1 (ConPatIn _ _) = False -- Conservative
- go1 (ConPatOut (L _ con) _ _ _ details _)
+ go1 (ConPatOut{ pat_con = L _ con, pat_args = details })
= isProductTyCon (dataConTyCon con)
&& all go (hsConArgs details)
import HsLit
import HsPat
import HsTypes
-import HscTypes ( DeprecTxt )
-import BasicTypes ( Fixity )
+import BasicTypes ( Fixity, DeprecTxt )
import HsUtils
-- others:
import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
import Type ( Type )
-import Kind ( {- instance Outputable Kind -} Kind,
+import {- Kind parts of -}
+ Type ( {- instance Outputable Kind -}, Kind,
pprParendKind, pprKind, isLiftedTypeKind )
import BasicTypes ( IPName, Boxity, tupleParens )
import SrcLoc ( Located(..), unLoc, noSrcSpan )
mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
-mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
-mkHsTyApp expr [] = expr
-mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
+nlHsTyApp :: name -> [Type] -> LHsExpr name
+nlHsTyApp fun_id tys = noLoc (HsCoerce (CoTyApps tys) (HsVar fun_id))
-mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
-mkHsDictApp expr [] = expr
-mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
+mkLHsCoerce :: ExprCoFn -> LHsExpr id -> LHsExpr id
+mkLHsCoerce co_fn (L loc e) = L loc (mkHsCoerce co_fn e)
mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id
mkHsCoerce co_fn e | isIdCoercion co_fn = e
mkMatchGroup :: [LMatch id] -> MatchGroup id
mkMatchGroup matches = MatchGroup matches placeHolderType
-mkHsTyLam [] expr = expr
-mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
-
-mkHsDictLam [] expr = expr
-mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
-
mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
-- Used for the dictionary bindings gotten from TcSimplify
-- We make them recursive to be on the safe side
mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
-- Used for constructing dictinoary terms etc, so no locations
mkHsConApp data_con tys args
- = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
+ = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
where
mk_app f a = noLoc (HsApp f (noLoc a))
go (TuplePat pats _ _) = foldr collectl bndrs pats
go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps)
- go (ConPatOut c _ ds bs ps _) = map noLoc ds
+ go (ConPatOut { pat_dicts = ds,
+ pat_binds = bs, pat_args = ps })
+ = map noLoc ds
++ collectHsBindLocatedBinders bs
++ foldr collectl bndrs (hsConArgs ps)
go (LitPat _) = bndrs
projects / ghc-hetmet.git / commitdiff