Commit 108361d0 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

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 <chak@cse.unsw.edu.au>
  * 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.
parent bd865113
......@@ -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
......
......@@ -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 )
......
......@@ -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
......
......@@ -9,7 +9,7 @@ module HsPat (
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}
......@@ -261,11 +280,11 @@ 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 (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
......@@ -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)
......
......@@ -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:
......
......@@ -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 )
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment