Fix scoped type variables for expression type signatures

[ghc-hetmet.git] / compiler / iface / TcIface.lhs

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 2831c2d..20aaa9f 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -27,15 +27,14 @@ import TcRnMonad
 import Type            ( liftedTypeKind, splitTyConApp, mkTyConApp,
                           liftedTypeKindTyCon, unliftedTypeKindTyCon, 
                           openTypeKindTyCon, argTypeKindTyCon, 
-                          ubxTupleKindTyCon,
-                         mkTyVarTys, ThetaType )
+                          ubxTupleKindTyCon, ThetaType )
 import TypeRep         ( Type(..), PredType(..) )
-import TyCon           ( TyCon, tyConName, SynTyConRhs(..), 
-                         AlgTyConParent(..) )
+import TyCon           ( TyCon, tyConName, SynTyConRhs(..), setTyConArgPoss )
 import HscTypes                ( ExternalPackageState(..), 
                          TyThing(..), tyThingClass, tyThingTyCon, 
                          ModIface(..), ModDetails(..), HomeModInfo(..),
-                         emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
+                         emptyModDetails, lookupTypeEnv, lookupType,
+                         typeEnvIds, mkDetailsFamInstCache )
 import InstEnv         ( Instance(..), mkImportedInstance )
 import CoreSyn
 import CoreUtils       ( exprType, dataConRepFSInstPat )
@@ -50,9 +49,9 @@ import IdInfo         ( IdInfo, CafInfo(..), WorkerInfo(..),
                          vanillaIdInfo, newStrictnessInfo )
 import Class           ( Class )
 import TyCon           ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
-import DataCon         ( DataCon, dataConWorkId, dataConExTyVars, dataConInstArgTys )
+import DataCon         ( DataCon, dataConWorkId )
 import TysWiredIn      ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
-import Var             ( TyVar, mkTyVar, tyVarKind )
+import Var             ( TyVar, mkTyVar )
 import Name            ( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
                          nameOccName, wiredInNameTyThing_maybe )
 import NameEnv
@@ -66,10 +65,11 @@ import Outputable
 import ErrUtils                ( Message )
 import Maybes          ( MaybeErr(..) )
 import SrcLoc          ( noSrcLoc )
-import Util            ( zipWithEqual, equalLength, splitAtList )
+import Util            ( zipWithEqual, equalLength )
 import DynFlags                ( DynFlag(..), isOneShot )
 
-import Monad           ( liftM )
+import List            ( elemIndex)
+import Maybe           ( catMaybes )
 \end{code}
 
 This module takes
@@ -221,10 +221,12 @@ typecheckIface iface
        ; exports <-  ifaceExportNames (mi_exports iface)
 
                -- Finished
-       ; return (ModDetails {  md_types = type_env, 
-                               md_insts = dfuns,
-                               md_rules = rules,
-                               md_exports = exports }) 
+       ; return $ ModDetails { md_types     = type_env
+                             , md_insts     = dfuns
+                             , md_fam_insts = mkDetailsFamInstCache type_env
+                             , md_rules     = rules
+                             , md_exports   = exports 
+                             }
     }
 \end{code}
 
@@ -370,7 +372,9 @@ tcIfaceDecl (IfaceData {ifName = occ_name,
            ; famInst <- 
                case mb_family of
                  Nothing         -> return Nothing
-                 Just (fam, tys) -> 
+                 Just (IfaceFamInst { ifFamInstTyCon = fam
+                                    , ifFamInstTys   = tys
+                                    }) -> 
                    do { famTyCon <- tcIfaceTyCon fam
                       ; insttys <- mapM tcIfaceType tys
                       ; return $ Just (famTyCon, insttys)
@@ -393,8 +397,9 @@ tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
      ; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
      }
 
-tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, 
-                        ifFDs = rdr_fds, ifSigs = rdr_sigs, 
+tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, 
+                        ifTyVars = tv_bndrs, ifFDs = rdr_fds, 
+                        ifATs = rdr_ats, ifSigs = rdr_sigs, 
                         ifRec = tc_isrec })
 -- ToDo: in hs-boot files we should really treat abstract classes specially,
 --      as we do abstract tycons
@@ -403,7 +408,9 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd
     ; ctxt <- tcIfaceCtxt rdr_ctxt
     ; sigs <- mappM tc_sig rdr_sigs
     ; fds  <- mappM tc_fd rdr_fds
-    ; cls  <- buildClass cls_name tyvars ctxt fds sigs tc_isrec
+    ; ats'  <- mappM tcIfaceDecl rdr_ats
+    ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats)
+    ; cls  <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec
     ; return (AClass cls) }
   where
    tc_sig (IfaceClassOp occ dm rdr_ty)
@@ -420,6 +427,19 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd
                           ; tvs2' <- mappM tcIfaceTyVar tvs2
                           ; return (tvs1', tvs2') }
 
+   -- For each AT argument compute the position of the corresponding class
+   -- parameter in the class head.  This will later serve as a permutation
+   -- vector when checking the validity of instance declarations.
+   setTyThingPoss (ATyCon tycon) atTyVars = 
+     let classTyVars = map fst tv_bndrs
+        poss        =   catMaybes 
+                      . map ((`elemIndex` classTyVars) . fst) 
+                      $ atTyVars
+                   -- There will be no Nothing, as we already passed renaming
+     in 
+     ATyCon (setTyConArgPoss tycon poss)
+   setTyThingPoss _              _ = panic "TcIface.setTyThingPoss"
+
 tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
   = do { name <- lookupIfaceTop rdr_name
        ; return (ATyCon (mkForeignTyCon name ext_name