Store a SrcSpan instead of a SrcLoc inside a Name

[ghc-hetmet.git] / compiler / typecheck / TcTyClsDecls.lhs

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 4313ad9..34022db 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -252,7 +252,8 @@ tcFamInstDecl (L loc decl)
 
 tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing)   -- Nothing if error
 
-tcFamInstDecl1 (decl@TySynonym {})
+  -- "type instance"
+tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
     do { -- check that the family declaration is for a synonym
         unless (isSynTyCon family) $
@@ -266,10 +267,15 @@ tcFamInstDecl1 (decl@TySynonym {})
        ; t_typats <- mappM tcHsKindedType k_typats
        ; t_rhs    <- tcHsKindedType k_rhs
 
-         -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs
-       ; return Nothing     -- !!!TODO: need TyThing for indexed synonym
+         -- (3) construct representation tycon
+       ; rep_tc_name <- newFamInstTyConName tc_name loc
+       ; tycon <- buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
+                                (Just (family, t_typats))
+
+       ; return $ Just (ATyCon tycon)
        }}
-      
+
+  -- "newtype instance" and "data instance"
 tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                             tcdCons = cons})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
@@ -300,7 +306,8 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
        ; t_typats     <- mappM tcHsKindedType k_typats
        ; stupid_theta <- tcHsKindedContext k_ctxt
 
-       ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc)
+         -- (3) construct representation tycon
+       ; rep_tc_name <- newFamInstTyConName tc_name loc
        ; tycon <- fixM (\ tycon -> do 
             { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs))
                                  k_cons
@@ -587,12 +594,15 @@ tcSynDecls (decl : decls)
        ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls)
        ; return (syn_tc : syn_tcs) }
 
+  -- "type"
 tcSynDecl
   (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
   = tcTyVarBndrs tvs           $ \ tvs' -> do 
     { traceTc (text "tcd1" <+> ppr tc_name) 
     ; rhs_ty' <- tcHsKindedType rhs_ty
-    ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) }
+    ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') Nothing
+    ; return (ATyCon tycon) 
+    }
 
 --------------------
 tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
@@ -614,7 +624,8 @@ tcTyClDecl1 _calc_isrec
        -- Check that we don't use families without -findexed-types
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
-  ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing)]
+  ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing
+  ; return [ATyCon tycon]
   }
 
   -- "newtype family" or "data family" declaration
@@ -639,7 +650,7 @@ tcTyClDecl1 _calc_isrec
   ; return [ATyCon tycon]
   }
 
-  -- "newtype", "data", "newtype instance", "data instance"
+  -- "newtype" and "data"
 tcTyClDecl1 calc_isrec
   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
           tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
@@ -960,23 +971,23 @@ checkValidTyCon tc
                -- NB: this check assumes that all the constructors of a given
                -- data type use the same type variables
         where
-        tvs1 = mkVarSet (dataConAllTyVars con1)
-        res1 = dataConResTys con1
+       (tvs1, _, _, res1) = dataConSig con1
+        ts1 = mkVarSet tvs1
         fty1 = dataConFieldType con1 label
 
         checkOne (_, con2)    -- Do it bothways to ensure they are structurally identical
-           = do { checkFieldCompat label con1 con2 tvs1 res1 res2 fty1 fty2
-                ; checkFieldCompat label con2 con1 tvs2 res2 res1 fty2 fty1 }
+           = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2
+                ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 }
            where        
-                tvs2 = mkVarSet (dataConAllTyVars con2)
-               res2 = dataConResTys con2 
+               (tvs2, _, _, res2) = dataConSig con2
+               ts2 = mkVarSet tvs2
                 fty2 = dataConFieldType con2 label
 
 checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
   = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
        ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
   where
-    mb_subst1 = tcMatchTys tvs1 res1 res2
+    mb_subst1 = tcMatchTy tvs1 res1 res2
     mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
 
 -------------------------------
@@ -1003,7 +1014,7 @@ checkNewDataCon con
                -- No existentials
     }
   where
-    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig con
+    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
 
 -------------------------------
 checkValidClass :: Class -> TcM ()
@@ -1186,6 +1197,7 @@ wrongKindOfFamily family =
     kindOfFamily | isSynTyCon  family = ptext SLIT("type synonym")
                 | isDataTyCon family = ptext SLIT("data type")
                 | isNewTyCon  family = ptext SLIT("newtype")
+                | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
 
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),