From: Manuel M T Chakravarty Date: Fri, 15 Sep 2006 21:19:18 +0000 (+0000) Subject: Massive patch for the first months work adding System FC to GHC #14 X-Git-Tag: After_FC_branch_merge~119 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=108361d05dfb0aa37871c2c6a4ddec45a1b68010 Massive patch for the first months work adding System FC to GHC #14 Fri Aug 4 15:59:09 EDT 2006 Manuel M T Chakravarty * Massive patch for the first months work adding System FC to GHC #14 Broken up massive patch -=chak Original log message: This is (sadly) all done in one patch to avoid Darcs bugs. It's not complete work... more FC stuff to come. A compiler using just this patch will fail dismally. --- diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 31c1cae..940b6d3 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -16,7 +16,9 @@ import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr, 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 ) @@ -296,20 +298,43 @@ instance (OutputableBndr id) => Outputable (IPBind id) where %************************************************************************ \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 diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 99d58ea..8078e7a 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -39,16 +39,14 @@ import HsPat ( HsConDetails(..), hsConArgs ) 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 ) diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index f7d7bda..dbe2937 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -239,21 +239,6 @@ The renamer translates them into the Right Thing. 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) @@ -394,33 +379,8 @@ ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e 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 diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 953d228..5bb443b 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -5,11 +5,11 @@ \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, @@ -22,7 +22,7 @@ module HsPat ( 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 ) @@ -81,12 +81,15 @@ data Pat id | 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: @@ -120,6 +123,12 @@ data Pat id | 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 @@ -169,7 +178,8 @@ pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) 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 @@ -182,6 +192,7 @@ pprPat (NPat l Nothing _ _) = ppr l 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-}"), @@ -214,13 +225,21 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \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} @@ -260,14 +279,14 @@ isWildPat other = False 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 @@ -301,6 +320,7 @@ isIrrefutableHsPat pat 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 @@ -310,7 +330,7 @@ isIrrefutableHsPat 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) diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index 0efa1e3..2169b1a 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -32,8 +32,7 @@ import HsImpExp import HsLit import HsPat import HsTypes -import HscTypes ( DeprecTxt ) -import BasicTypes ( Fixity ) +import BasicTypes ( Fixity, DeprecTxt ) import HsUtils -- others: diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index ac6a0f9..7c17318 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -31,7 +31,8 @@ module HsTypes ( 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 ) diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 50d12a3..cbc59c4 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -71,13 +71,11 @@ mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) 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 @@ -91,12 +89,6 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) 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 @@ -109,7 +101,7 @@ mkHsDictLet binds expr 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)) @@ -385,7 +377,9 @@ collectl (L l pat) bndrs 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