Massive patch for the first months work adding System FC to GHC #14
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Fri, 15 Sep 2006 21:19:18 +0000 (21:19 +0000)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Fri, 15 Sep 2006 21:19:18 +0000 (21:19 +0000)
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.

compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsSyn.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs

index 31c1cae..940b6d3 100644 (file)
@@ -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
index 99d58ea..8078e7a 100644 (file)
@@ -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 )
index f7d7bda..dbe2937 100644 (file)
@@ -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
 
index 953d228..5bb443b 100644 (file)
@@ -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)
 
index 0efa1e3..2169b1a 100644 (file)
@@ -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:
index ac6a0f9..7c17318 100644 (file)
@@ -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 )
index 50d12a3..cbc59c4 100644 (file)
@@ -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