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.

7 files changed, 90 insertions, 93 deletions

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 31c1cae459..940b6d3e24 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 99d58ea345..8078e7a2a8 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 f7d7bda813..dbe29376bf 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 953d228942..5bb443b8e3 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 0efa1e32c8..2169b1a3b6 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 ac6a0f9751..7c17318074 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 50d12a3dc7..cbc59c4ba4 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