Migrate cvs diff from fptools-assoc branch
[ghc-hetmet.git] / compiler / rename / RnSource.lhs
index bd9c549..477307e 100644 (file)
@@ -15,8 +15,8 @@ module RnSource (
 import {-# SOURCE #-} RnExpr( rnLExpr )
 
 import HsSyn
-import RdrName         ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts,
-                         GlobalRdrElt(..), isLocalGRE )
+import RdrName         ( RdrName, isRdrDataCon, isRdrTyVar, elemLocalRdrEnv, 
+                         globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE )
 import RdrHsSyn                ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
 import RnHsSyn
 import RnTypes         ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
@@ -42,6 +42,7 @@ import SrcLoc         ( Located(..), unLoc, noLoc )
 import DynFlags        ( DynFlag(..) )
 import Maybes          ( seqMaybe )
 import Maybe            ( isNothing )
+import Monad           ( liftM )
 import BasicTypes       ( Boxity(..) )
 \end{code}
 
@@ -109,8 +110,10 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
           <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
        
        let {
+           rn_at_decls = concat 
+                          [ats | L _ (InstDecl _ _ _ ats) <- rn_inst_decls] ;
           rn_group = HsGroup { hs_valds  = rn_val_decls,
-                               hs_tyclds = rn_tycl_decls,
+                               hs_tyclds = rn_tycl_decls ++ rn_at_decls,
                                hs_instds = rn_inst_decls,
                                hs_fixds  = rn_fix_decls,
                                hs_depds  = [],
@@ -246,15 +249,15 @@ rnDefaultDecl (DefaultDecl tys)
 %*********************************************************
 
 \begin{code}
-rnHsForeignDecl (ForeignImport name ty spec isDeprec)
+rnHsForeignDecl (ForeignImport name ty spec)
   = lookupLocatedTopBndrRn name                `thenM` \ name' ->
     rnHsTypeFVs (fo_decl_msg name) ty  `thenM` \ (ty', fvs) ->
-    returnM (ForeignImport name' ty' spec isDeprec, fvs)
+    returnM (ForeignImport name' ty' spec, fvs)
 
-rnHsForeignDecl (ForeignExport name ty spec isDeprec)
+rnHsForeignDecl (ForeignExport name ty spec)
   = lookupLocatedOccRn name            `thenM` \ name' ->
     rnHsTypeFVs (fo_decl_msg name) ty          `thenM` \ (ty', fvs) ->
-    returnM (ForeignExport name' ty' spec isDeprec, fvs )
+    returnM (ForeignExport name' ty' spec, fvs )
        -- NB: a foreign export is an *occurrence site* for name, so 
        --     we add it to the free-variable list.  It might, for example,
        --     be imported from another module
@@ -270,10 +273,21 @@ fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
 %*********************************************************
 
 \begin{code}
-rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
+rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
        -- Used for both source and interface file decls
   = rnHsSigType (text "an instance decl") inst_ty      `thenM` \ inst_ty' ->
 
+       -- Rename the associated types
+       -- The typechecker (not the renamer) checks that all 
+       -- the declarations are for the right class
+    let
+       at_doc   = text "In the associated types in an instance declaration"
+       at_names = map (head . tyClDeclNames . unLoc) ats
+       (_, rdrCtxt, _, _) = splitHsInstDeclTy (unLoc inst_ty)
+    in
+    checkDupNames at_doc at_names              `thenM_`
+    rnATDefs rdrCtxt ats                       `thenM` \ (ats', at_fvs) ->
+
        -- Rename the bindings
        -- The typechecker (not the renamer) checks that all 
        -- the bindings are for the right class
@@ -302,9 +316,36 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
     in
     bindLocalNames binders (renameSigs ok_sig uprags)  `thenM` \ uprags' ->
 
-    returnM (InstDecl inst_ty' mbinds' uprags',
-            meth_fvs `plusFV` hsSigsFVs uprags'
+    returnM (InstDecl inst_ty' mbinds' uprags' ats',
+            meth_fvs `plusFV` at_fvs
+                     `plusFV` hsSigsFVs uprags'
                      `plusFV` extractHsTyNames inst_ty')
+             -- We return the renamed associated data type declarations so
+             -- that they can be entered into the list of type declarations
+             -- for the binding group, but we also keep a copy in the instance.
+             -- The latter is needed for well-formedness checks in the type
+             -- checker (eg, to ensure that all ATs of the instance actually
+             -- receive a declaration). 
+            -- NB: Even the copies in the instance declaration carry copies of
+            --     the instance context after renaming.  This is a bit
+            --     strange, but should not matter (and it would be more work
+            --     to remove the context).
+\end{code}
+
+Renaming of the associated data definitions requires adding the instance
+context, as the rhs of an AT declaration may use ATs from classes in the
+context.
+
+\begin{code}
+rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName] 
+         -> RnM ([LTyClDecl Name], FreeVars)
+rnATDefs ctxt atDecls = 
+  mapFvRn (wrapLocFstM addCtxtAndRename) atDecls
+  where
+    -- The parser won't accept anything, but a data declaration
+    addCtxtAndRename ty@TyData {tcdCtxt = L l tyCtxt} = 
+      rnTyClDecl (ty {tcdCtxt = L l (ctxt ++ tyCtxt)})
+      -- The source loc is somewhat half hearted... -=chak
 \end{code}
 
 For the method bindings in class and instance decls, we extend the 
@@ -335,15 +376,9 @@ rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
 
     rnLExpr lhs                                        `thenM` \ (lhs', fv_lhs') ->
     rnLExpr rhs                                        `thenM` \ (rhs', fv_rhs') ->
-    let
-       mb_bad = validRuleLhs ids lhs'
-    in
-    checkErr (isNothing mb_bad)
-            (badRuleLhsErr rule_name lhs' mb_bad)      `thenM_`
-    let
-       bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
-    in
-    mappM (addErr . badRuleVar rule_name) bad_vars     `thenM_`
+
+    checkValidRule rule_name ids lhs' fv_lhs'  `thenM_`
+
     returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
             fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
   where
@@ -357,17 +392,38 @@ rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
     rn_var (RuleBndrSig (L loc v) t, id)
        = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
          returnM (RuleBndrSig (L loc id) t', fvs)
+
+badRuleVar name var
+  = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
+        ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
+               ptext SLIT("does not appear on left hand side")]
 \end{code}
 
-Check the shape of a transformation rule LHS.  Currently
-we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
-not one of the @forall@'d variables.  We also restrict the form of the LHS so
-that it may be plausibly matched.  Basically you only get to write ordinary 
-applications.  (E.g. a case expression is not allowed: too elaborate.)
+Note [Rule LHS validity checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Check the shape of a transformation rule LHS.  Currently we only allow
+LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
+@forall@'d variables.  
 
-NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
+We used restrict the form of the 'ei' to prevent you writing rules
+with LHSs with a complicated desugaring (and hence unlikely to match);
+(e.g. a case expression is not allowed: too elaborate.)
 
+But there are legitimate non-trivial args ei, like sections and
+lambdas.  So it seems simmpler not to check at all, and that is why
+check_e is commented out.
+       
 \begin{code}
+checkValidRule rule_name ids lhs' fv_lhs'
+  = do         {       -- Check for the form of the LHS
+         case (validRuleLhs ids lhs') of
+               Nothing  -> return ()
+               Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
+
+               -- Check that LHS vars are all bound
+       ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
+       ; mappM (addErr . badRuleVar rule_name) bad_vars }
+
 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 -- Nothing => OK
 -- Just e  => Not ok, and e is the offending expression
@@ -381,8 +437,10 @@ validRuleLhs foralls lhs
     check (HsVar v) | v `notElem` foralls = Nothing
     check other                                  = Just other  -- Failure
 
-    checkl_e (L loc e) = check_e e
+       -- Check an argument
+    checkl_e (L loc e) = Nothing       -- Was (check_e e); see Note [Rule LHS validity checking]
 
+{-     Commented out; see Note [Rule LHS validity checking] above 
     check_e (HsVar v)     = Nothing
     check_e (HsPar e)    = checkl_e e
     check_e (HsLit e)    = Nothing
@@ -396,18 +454,14 @@ validRuleLhs foralls lhs
     check_e other               = Just other   -- Fails
 
     checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
+-}
 
-badRuleLhsErr name lhs (Just bad_e)
+badRuleLhsErr name lhs bad_e
   = sep [ptext SLIT("Rule") <+> ftext name <> colon,
         nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, 
                       ptext SLIT("in left-hand side:") <+> ppr lhs])]
     $$
     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
-
-badRuleVar name var
-  = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
-        ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
-               ptext SLIT("does not appear on left hand side")]
 \end{code}
 
 
@@ -437,27 +491,30 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_
             emptyFVs)
 
 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
-                   tcdTyVars = tyvars, tcdCons = condecls, 
-                   tcdKindSig = sig, tcdDerivs = derivs})
+                   tcdTyVars = tyvars, tcdTyPats = typatsMaybe, 
+                   tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs})
   | is_vanilla -- Normal Haskell data type decl
   = ASSERT( isNothing sig )    -- In normal H98 form, kind signature on the 
                                -- data type is syntactically illegal
     bindTyVarsRn data_doc tyvars               $ \ tyvars' ->
     do { tycon' <- lookupLocatedTopBndrRn tycon
        ; context' <- rnContext data_doc context
+       ; typats' <- rnTyPats data_doc typatsMaybe
        ; (derivs', deriv_fvs) <- rn_derivs derivs
        ; checkDupNames data_doc con_names
        ; condecls' <- rnConDecls (unLoc tycon') condecls
-       ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
-                          tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls', 
-                          tcdDerivs = derivs'}, 
+       ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', 
+                          tcdLName = tycon', tcdTyVars = tyvars', 
+                          tcdTyPats = typats', tcdKindSig = Nothing, 
+                          tcdCons = condecls', tcdDerivs = derivs'}, 
                   delFVs (map hsLTyVarName tyvars')    $
                   extractHsCtxtTyNames context'        `plusFV`
-                  plusFVs (map conDeclFVs condecls') `plusFV`
+                  plusFVs (map conDeclFVs condecls')   `plusFV`
                   deriv_fvs) }
 
   | otherwise  -- GADT
-  = do { tycon' <- lookupLocatedTopBndrRn tycon
+  = ASSERT( null typats )       -- GADTs cannot have type patterns for now
+    do { tycon' <- lookupLocatedTopBndrRn tycon
        ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
        ; tyvars' <- bindTyVarsRn data_doc tyvars 
                                  (\ tyvars' -> return tyvars')
@@ -467,9 +524,10 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
        ; (derivs', deriv_fvs) <- rn_derivs derivs
        ; checkDupNames data_doc con_names
        ; condecls' <- rnConDecls (unLoc tycon') condecls
-       ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
-                          tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
-                          tcdDerivs = derivs'}, 
+       ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], 
+                          tcdLName = tycon', tcdTyVars = tyvars', 
+                          tcdTyPats = Nothing, tcdKindSig = sig,
+                          tcdCons = condecls', tcdDerivs = derivs'}, 
                   plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
 
   where
@@ -499,16 +557,23 @@ rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
 
 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
                       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
-                      tcdMeths = mbinds})
+                      tcdMeths = mbinds, tcdATs = ats})
   = lookupLocatedTopBndrRn cname               `thenM` \ cname' ->
 
        -- Tyvars scope over superclass context and method signatures
     bindTyVarsRn cls_doc tyvars                        ( \ tyvars' ->
        rnContext cls_doc context       `thenM` \ context' ->
        rnFds cls_doc fds               `thenM` \ fds' ->
+       rnATs tyvars' ats               `thenM` \ (ats', ats_fvs) ->
        renameSigs okClsDclSig sigs     `thenM` \ sigs' ->
-       returnM   (tyvars', context', fds', sigs')
-    )  `thenM` \ (tyvars', context', fds', sigs') ->
+       returnM   (tyvars', context', fds', (ats', ats_fvs), sigs')
+    )  `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') ->
+
+       -- Check for duplicates among the associated types
+    let
+      at_rdr_names_w_locs      = [tcdLName ty | L _ ty <- ats]
+    in
+    checkDupNames at_doc at_rdr_names_w_locs   `thenM_`
 
        -- Check the signatures
        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
@@ -542,17 +607,20 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
         rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
     ) `thenM` \ (mbinds', meth_fvs) ->
 
-    returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
-                        tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
+    returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', 
+                        tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
+                        tcdMeths = mbinds', tcdATs = ats'},
             delFVs (map hsLTyVarName tyvars')  $
             extractHsCtxtTyNames context'          `plusFV`
             plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
             hsSigsFVs sigs'                        `plusFV`
-            meth_fvs)
+            meth_fvs                               `plusFV`
+            ats_fvs)
   where
     meth_doc = text "In the default-methods for class" <+> ppr cname
     cls_doc  = text "In the declaration for class"     <+> ppr cname
     sig_doc  = text "In the signatures for class"      <+> ppr cname
+    at_doc   = text "In the associated types for class"        <+> ppr cname
 
 badGadtStupidTheta tycon
   = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
@@ -566,6 +634,14 @@ badGadtStupidTheta tycon
 %*********************************************************
 
 \begin{code}
+-- Although, we are processing type patterns here, all type variables should
+-- already be in scope (they are the same as in the 'tcdTyVars' field of the
+-- type declaration to which these patterns belong)
+--
+rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
+rnTyPats _   Nothing       = return Nothing
+rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
+
 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 rnConDecls tycon condecls
   = mappM (wrapLocM rnConDecl) condecls
@@ -593,18 +669,22 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty)
        ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
        { new_context <- rnContext doc cxt
         ; new_details <- rnConDetails doc details
-        ; new_res_ty  <- rnConResult doc res_ty
-        ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty
-        ; traceRn (text "****** - autrijus" <> ppr rv)
-        ; return rv } }
+        ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
+        ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
   where
     doc = text "In the definition of data constructor" <+> quotes (ppr name)
     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 
-rnConResult _ ResTyH98 = return ResTyH98
-rnConResult doc (ResTyGADT ty) = do
+rnConResult _ details ResTyH98 = return (details, ResTyH98)
+
+rnConResult doc details (ResTyGADT ty) = do
     ty' <- rnHsSigType doc ty
-    return $ ResTyGADT ty'
+    let (arg_tys, res_ty) = splitHsFunType ty'
+       -- We can split it up, now the renamer has dealt with fixities
+    case details of
+       PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
+       RecCon fields -> return (details, ResTyGADT ty')
+       InfixCon {}   -> panic "rnConResult"
 
 rnConDetails doc (PrefixCon tys)
   = mappM (rnLHsType doc) tys  `thenM` \ new_tys  ->
@@ -663,6 +743,77 @@ rnFds doc fds
 
 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 rnHsTyvar doc tyvar = lookupOccRn tyvar
+
+-- Rename associated data type declarations
+--
+rnATs :: [LHsTyVarBndr Name] -> [LTyClDecl RdrName] 
+      -> RnM ([LTyClDecl Name], FreeVars)
+rnATs classLTyVars ats
+  = mapFvRn (wrapLocFstM rn_at) ats
+  where
+    -- The parser won't accept anything, but a data declarations
+    rn_at (tydecl@TyData {tcdCtxt = L ctxtL ctxt, tcdLName = tycon, 
+                         tcdTyPats = Just typats, tcdCons = condecls,
+                         tcdDerivs = derivs}) =
+      do { checkM (null ctxt    ) $ addErr atNoCtxt    -- no context
+         ; checkM (null condecls) $ addErr atNoCons    -- no constructors
+        -- check and collect type parameters
+         ; let (idxParms, excessParms) = splitAt (length classLTyVars) typats
+        ; zipWithM_ cmpTyVar idxParms classLTyVars
+        ; excessTyVars <- liftM catMaybes $ mappM chkTyVar excessParms
+        -- bind excess parameters
+        ; bindTyVarsRn data_doc excessTyVars   $ \ excessTyVars' -> do {
+        ; tycon' <- lookupLocatedTopBndrRn tycon
+        ; (derivs', deriv_fvs) <- rn_derivs derivs
+        ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = L ctxtL [], 
+                           tcdLName = tycon', 
+                           tcdTyVars = classLTyVars ++ excessTyVars',
+                           tcdTyPats = Nothing, tcdKindSig = Nothing, 
+                           tcdCons = [], tcdDerivs = derivs'}, 
+                   delFVs (map hsLTyVarName (classLTyVars ++ excessTyVars')) $
+                   deriv_fvs) } }
+      where
+           -- Check that the name space is correct!
+       cmpTyVar (L l ty@(HsTyVar tv)) classTV =      -- just a type variable
+         checkM (rdrNameOcc tv == nameOccName classTVName) $ 
+           mustMatchErr l ty classTVName
+          where
+           classTVName = hsLTyVarName classTV
+       cmpTyVar (L l ty@(HsKindSig (L _ (HsTyVar tv)) k)) _ | isRdrTyVar tv = 
+         noKindSigErr l tv   -- additional kind sig not allowed at class parms
+       cmpTyVar (L l otherTy) _ = 
+         tyVarExpectedErr l  -- parameter must be a type variable
+
+           -- Check that the name space is correct!
+       chkTyVar (L l (HsKindSig (L _ (HsTyVar tv)) k))
+         | isRdrTyVar tv      = return $ Just (L l (KindedTyVar tv k))
+       chkTyVar (L l (HsTyVar tv))
+         | isRdrTyVar tv      = return $ Just (L l (UserTyVar tv))
+       chkTyVar (L l otherTy) = tyVarExpectedErr l >> return Nothing
+                                -- drop parameter; we stop after renaming anyways
+
+        rn_derivs Nothing   = returnM (Nothing, emptyFVs)
+        rn_derivs (Just ds) = do
+                               ds' <- rnLHsTypes data_doc ds
+                               returnM (Just ds', extractHsTyNames_s ds')
+    
+        atNoCtxt = text "Associated data type declarations cannot have a context"
+        atNoCons = text "Associated data type declarations cannot have any constructors"
+        data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
+
+noKindSigErr l ty =
+  addErrAt l $
+    sep [ptext SLIT("No kind signature allowed at copies of class parameters:"),
+         nest 2 $ ppr ty]
+
+mustMatchErr l ty classTV =
+  addErrAt l $
+    sep [ptext SLIT("Type variable"), quotes (ppr ty), 
+        ptext SLIT("must match corresponding class parameter"), 
+        quotes (ppr classTV)]
+
+tyVarExpectedErr l = 
+  addErrAt l (ptext SLIT("Type found where type variable expected"))
 \end{code}