New syntax for GADT-style record declarations, and associated refactoring
[ghc-hetmet.git] / compiler / typecheck / TcTyClsDecls.lhs
index 158eb64..633dc52 100644 (file)
@@ -271,11 +271,12 @@ tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
 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) $
-          addErr (wrongKindOfFamily family)
+         checkTc (isOpenTyCon family) (notFamily family)
+       ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
 
        ; -- (1) kind check the right-hand side of the type equation
-       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) resKind
+       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
+                         -- ToDo: the ExpKind could be better
 
          -- we need the exact same number of type parameters as the family
          -- declaration 
@@ -302,8 +303,8 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                             tcdCons = cons})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
     do { -- check that the family declaration is for the right kind
-        unless (isAlgTyCon fam_tycon) $
-          addErr (wrongKindOfFamily fam_tycon)
+         checkTc (isOpenTyCon fam_tycon) (notFamily fam_tycon)
+       ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
 
        ; -- (1) kind check the data declaration as usual
        ; k_decl <- kcDataDecl decl k_tvs
@@ -378,7 +379,8 @@ kcIdxTyPats :: TyClDecl Name
            -> TcM a
 kcIdxTyPats decl thing_inside
   = kcHsTyVars (tcdTyVars decl) $ \tvs -> 
-    do { fam_tycon <- tcLookupLocatedTyCon (tcdLName decl)
+    do { let tc_name = tcdLName decl
+       ; fam_tycon <- tcLookupLocatedTyCon tc_name
        ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
             ; hs_typats        = fromJust $ tcdTyPats decl }
 
@@ -388,10 +390,11 @@ kcIdxTyPats decl thing_inside
 
          -- type functions can have a higher-kinded result
        ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
-       ; typats <- zipWithM kcCheckLHsType hs_typats kinds
+       ; typats <- zipWithM kcCheckLHsType hs_typats 
+                                   [ EK kind (EkArg (ppr tc_name) n) 
+                            | (kind,n) <- kinds `zip` [1..]]
        ; thing_inside tvs typats resultKind fam_tycon
        }
-  where
 \end{code}
 
 
@@ -587,7 +590,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
        ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
   where
     -- doc comments are typechecked to Nothing here
-    kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) 
+    kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
+                                  , con_cxt = ex_ctxt, con_details = details, con_res = res })
       = addErrCtxt (dataConCtxt name)  $ 
         kcHsTyVars ex_tvs $ \ex_tvs' -> do
         do { ex_ctxt' <- kcHsContext ex_ctxt
@@ -595,7 +599,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
            ; res'     <- case res of
                 ResTyH98 -> return ResTyH98
                 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
-           ; return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) }
+           ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
+                              , con_details = details', con_res = res' }) }
 
     kc_con_details (PrefixCon btys) 
        = do { btys' <- mapM kc_larg_ty btys 
@@ -826,7 +831,8 @@ tcConDecl :: Bool           -- True <=> -funbox-strict_fields
          -> TcM DataCon
 
 tcConDecl unbox_strict existential_ok rep_tycon res_tmpl       -- Data types
-         (ConDecl name _ tvs ctxt details res_ty _)
+         (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt
+                   , con_details = details, con_res = res_ty })
   = addErrCtxt (dataConCtxt name)      $ 
     tcTyVarBndrs tvs                   $ \ tvs' -> do 
     { ctxt' <- tcHsKindedContext ctxt
@@ -1095,7 +1101,8 @@ checkValidDataCon :: TyCon -> DataCon -> TcM ()
 checkValidDataCon tc con
   = setSrcSpan (srcLocSpan (getSrcLoc con))    $
     addErrCtxt (dataConCtxt con)               $ 
-    do { let tc_tvs = tyConTyVars tc
+    do { traceTc (ptext (sLit "Validity of data con") <+> ppr con)
+        ; let tc_tvs = tyConTyVars tc
              res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
              actual_res_ty = dataConOrigResTy con
        ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
@@ -1204,6 +1211,9 @@ checkValidClass cls
 
 \begin{code}
 mkAuxBinds :: [TyThing] -> HsValBinds Name
+-- NB We produce *un-typechecked* bindings, rather like 'deriving'
+--    This makes life easier, because the later type checking will add
+--    all necessary type abstractions and applications
 mkAuxBinds ty_things
   = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
   where
@@ -1212,47 +1222,44 @@ mkAuxBinds ty_things
                                        | ATyCon tc <- ty_things 
                                , fld <- tyConFields tc ]
 
-
 mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
 mkRecSelBind (tycon, sel_name)
   = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
   where
-    loc = getSrcSpan tycon    
-    sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
+    loc        = getSrcSpan tycon    
+    sel_id     = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
     rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
 
     -- Find a representative constructor, con1
-    all_cons = tyConDataCons tycon 
+    all_cons     = tyConDataCons tycon 
     cons_w_field = [ con | con <- all_cons
                    , sel_name `elem` dataConFieldLabels con ] 
     con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
 
     -- Selector type; Note [Polymorphic selectors]
-    field_ty = dataConFieldType con1 sel_name
-    (field_tvs, field_theta, field_tau) 
-       | is_naughty = ([], [], unitTy)
-       | otherwise  = tcSplitSigmaTy field_ty
+    field_ty   = dataConFieldType con1 sel_name
     data_ty    = dataConOrigResTy con1
     data_tvs   = tyVarsOfType data_ty
     is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)  
-    sel_ty = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ 
-            mkPhiTy (dataConStupidTheta con1)  $       -- Urgh!
-            mkPhiTy field_theta                $       -- Urgh!
-             mkFunTy data_ty field_tau
+    (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
+    sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
+           | otherwise  = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ 
+                         mkPhiTy (dataConStupidTheta con1) $   -- Urgh!
+                         mkPhiTy field_theta               $   -- Urgh!
+                         mkFunTy data_ty field_tau
 
     -- Make the binding: sel (C2 { fld = x }) = x
     --                   sel (C7 { fld = x }) = x
     --    where cons_w_field = [C2,C7]
-    sel_bind    = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
+    sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs]
+             | otherwise  = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
     mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] 
-                                 (L loc match_body)
+                                 (L loc (HsVar field_var))
     mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
     rec_field  = HsRecField { hsRecFieldId = sel_lname
                             , hsRecFieldArg = nlVarPat field_var
                             , hsRecPun = False }
-    match_body | is_naughty = ExplicitTuple [] Boxed
-              | otherwise  = HsVar field_var
     sel_lname = L loc sel_name
     field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
 
@@ -1263,6 +1270,8 @@ mkRecSelBind (tycon, sel_name)
          | otherwise = [mkSimpleMatch [nlWildPat] 
                            (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
                                     (nlHsLit msg_lit))]
+
+    unit_rhs = L loc $ ExplicitTuple [] Boxed
     msg_lit = HsStringPrim $ mkFastString $ 
               occNameString (getOccName sel_name)
 
@@ -1296,11 +1305,16 @@ so that if the user tries to use 'x' as a selector we can bleat
 helpfully, rather than saying unhelpfully that 'x' is not in scope.
 Hence the sel_naughty flag, to identify record selectors that don't really exist.
 
-In general, a field is naughty if its type mentions a type variable that
-isn't in the result type of the constructor.
+In general, a field is "naughty" if its type mentions a type variable that
+isn't in the result type of the constructor.  Note that this *allows*
+GADT record selectors (Note [GADT record selectors]) whose types may look 
+like     sel :: T [a] -> a
 
-We make a dummy binding for naughty selectors, so that they can be treated
-uniformly, apart from their sel_naughty field.  The function is never called.
+For naughty selectors we make a dummy binding 
+   sel = ()
+for naughty selectors, so that the later type-check will add them to the
+environment, and they'll be exported.  The function is never called, because
+the tyepchecker spots the sel_naughty field.
 
 Note [GADT record selectors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1513,13 +1527,18 @@ wrongNumberOfParmsErr exp_arity
     <+> ppr exp_arity
 
 badBootFamInstDeclErr :: SDoc
-badBootFamInstDeclErr = 
-  ptext (sLit "Illegal family instance in hs-boot file")
-
+badBootFamInstDeclErr
+  = ptext (sLit "Illegal family instance in hs-boot file")
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+  = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
+         , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
+  
 wrongKindOfFamily :: TyCon -> SDoc
-wrongKindOfFamily family =
-  ptext (sLit "Wrong category of family instance; declaration was for a") <+>
-  kindOfFamily
+wrongKindOfFamily family
+  = ptext (sLit "Wrong category of family instance; declaration was for a")
+    <+> kindOfFamily
   where
     kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
                 | isAlgTyCon family = ptext (sLit "data type")