Cleanup (re type function parsing)

Mon Jul 31 17:20:56 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Cleanup (re type function parsing)

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index f2bf9d3..059fe4d 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -329,6 +329,24 @@ Interface file code:
 -- for a module.  That's why (despite the misnomer) IfaceSig and ForeignType
 -- are both in TyClDecl
 
+-- Representation of type functions and associated data types & synonyms
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- 'TyData' and 'TySynonym' have a field 'tcdPats::Maybe [LHsType name]', with
+-- the following meaning:
+--
+--   * If it is 'Nothing', we have a *vanilla* data type declaration or type
+--     synonym declaration and 'tcdVars' contains the type parameters of the
+--     type constructor.
+--
+--   * If it is 'Just pats', we have the definition of an associated data type
+--     or a type function equations (toplevel or nested in an instance
+--     declarations).  Then, 'pats' are type patterns for the type-indexes of
+--     the type constructor and 'tcdVars' are the variables in those
+--     patterns.  Hence, the arity of the type constructor is 'length tcdPats'
+--     and *not* 'length tcdVars'.
+--
+-- In both cases, 'tcdVars' collects all variables we need to quantify over.
+
 type LTyClDecl name = Located (TyClDecl name)
 
 data TyClDecl name
@@ -368,6 +386,8 @@ data TyClDecl name
   | TySynonym {        tcdLName  :: Located name,              -- type constructor
                tcdTyVars :: [LHsTyVarBndr name],       -- type variables
                tcdTyPats :: Maybe [LHsType name],      -- Type patterns
+                                                       -- 'Nothing' => vanilla
+                                                       --   type synonym
                tcdSynRhs :: LHsType name               -- synonym expansion
     }
 
@@ -378,7 +398,8 @@ data TyClDecl name
                tcdSigs    :: [LSig name],              -- Methods' signatures
                tcdMeths   :: LHsBinds name,            -- Default methods
                tcdATs     :: [LTyClDecl name]          -- Associated types; ie
-                                                       --   only 'TyData'
+                                                       --   only 'TyData',
+                                                       --   'TyFunction',
                                                        --   and 'TySynonym'
     }
 
@@ -653,7 +674,8 @@ data InstDecl name
                                -- figures out the quantified type variables for us.
                (LHsBinds name)
                [LSig name]     -- User-supplied pragmatic info
-               [LTyClDecl name]-- Associated types
+               [LTyClDecl name]-- Associated types (ie, 'TyData' and
+                               -- 'TySynonym' only)
 
 instance (OutputableBndr name) => Outputable (InstDecl name) where
 

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 7b9786f..158043b 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -467,7 +467,7 @@ cl_decl :: { LTyClDecl RdrName }
        : 'class' tycl_hdr fds where
                {% do { let { (binds, sigs, ats)           = 
                                cvBindsAndSigs (unLoc $4)
-                           ; (ctxt, tc, tvs, Just tparms) = unLoc $2}
+                           ; (ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms False  -- only type vars allowed
                      ; return $ L (comb4 $1 $2 $3 $4) 
                                   (mkClassDecl (ctxt, tc, tvs) 
@@ -505,19 +505,25 @@ ty_decl :: { LTyClDecl RdrName }
 
         -- data type or newtype declaration
        | data_or_newtype tycl_hdr constrs deriving
-               { L (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr 
-                                       -- in case constrs and deriving are
-                                       -- both empty
-                   (mkTyData (unLoc $1) (unLoc $2) Nothing 
-                      (reverse (unLoc $3)) (unLoc $4)) }
+               {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
+                      ; tpats <- checkTyVars tparms True -- can have type pats
+                     ; return $
+                         L (comb4 $1 $2 $3 $4)
+                                  -- We need the location on tycl_hdr in case 
+                                  -- constrs and deriving are both empty
+                           (mkTyData (unLoc $1) (ctxt, tc, tvs, tpats) 
+                            Nothing (reverse (unLoc $3)) (unLoc $4)) } }
 
         -- GADT declaration
         | data_or_newtype tycl_hdr opt_kind_sig 
                 'where' gadt_constrlist
                 deriving
-               { L (comb4 $1 $2 $4 $5)
-                   (mkTyData (unLoc $1) (unLoc $2) $3
-                      (reverse (unLoc $5)) (unLoc $6)) }
+               {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
+                      ; tpats <- checkTyVars tparms True -- can have type pats
+                     ; return $
+                         L (comb4 $1 $2 $4 $5)
+                           (mkTyData (unLoc $1) (ctxt, tc, tvs, tpats) $3
+                            (reverse (unLoc $5)) (unLoc $6)) } }
 
 opt_iso :: { Bool }
        :       { False }
@@ -540,7 +546,7 @@ opt_kind_sig :: { Maybe Kind }
        :                               { Nothing }
        | '::' kind                     { Just (unLoc $2) }
 
--- tycl_hdr parses the header of a type decl,
+-- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
 --     T a b
 --     Eq a => T a
@@ -550,7 +556,7 @@ opt_kind_sig :: { Maybe Kind }
 tycl_hdr :: { Located (LHsContext RdrName, 
                       Located RdrName, 
                       [LHsTyVarBndr RdrName],
-                      Maybe [LHsType RdrName]) }
+                      [LHsType RdrName]) }
        : context '=>' type             {% checkTyClHdr $1         $3 >>= return.LL }
        | type                          {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
 

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index b0cf2cf..1867ce6 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -35,7 +35,7 @@ module RdrHsSyn (
        checkPrecP,           -- Int -> P Int
        checkContext,         -- HsType -> P HsContext
        checkPred,            -- HsType -> P HsPred
-       checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+       checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
        checkTyVars,          -- [LHsType RdrName] -> Bool -> P ()
        checkSynHdr,          -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
        checkTopTyClD,        -- LTyClDecl RdrName -> P (HsDecl RdrName)
@@ -401,7 +401,8 @@ checkTyVars tparms nonVarsOk =
 
 -- Check whether the type arguments in a type synonym head are simply
 -- variables.  If not, we have a type equation of a type function and return
--- all patterns.
+-- all patterns.  If yes, we return 'Nothing' as the third component to
+-- indicate a vanilla type synonym.
 --
 checkSynHdr :: LHsType RdrName 
            -> Bool                             -- non-variables admitted?
@@ -409,7 +410,7 @@ checkSynHdr :: LHsType RdrName
                  [LHsTyVarBndr RdrName],       -- parameters
                  Maybe [LHsType RdrName])      -- type patterns
 checkSynHdr ty nonVarsOk = 
-  do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
+  do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
      ; typats <- checkTyVars tparms nonVarsOk
      ; return (tc, tvs, typats) }
 
@@ -420,8 +421,7 @@ checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
   -> P (LHsContext RdrName,         -- the type context
         Located RdrName,            -- the head symbol (type or class name)
        [LHsTyVarBndr RdrName],      -- free variables of the non-context part
-       Maybe [LHsType RdrName])     -- parameters of head symbol; wrapped into
-                                    -- 'Maybe' for 'mkTyData'
+       [LHsType RdrName])           -- parameters of head symbol
 -- The header of a type or class decl should look like
 --     (C a, D b) => T a b
 -- or  T a b
@@ -437,7 +437,7 @@ checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
 checkTyClHdr (L l cxt) ty
   = do (tc, tvs, parms) <- gol ty []
        mapM_ chk_pred cxt
-       return (L l cxt, tc, tvs, Just parms)
+       return (L l cxt, tc, tvs, parms)
   where
     gol (L l ty) acc = go l ty acc