Simplify the API for TcHsType.kcHsTyVarBndrs
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 2 Nov 2016 11:48:51 +0000 (11:48 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 2 Nov 2016 11:54:55 +0000 (11:54 +0000)
Pass in a Bool rather than return a funcion!

No change in behaviour.

compiler/typecheck/TcHsType.hs
compiler/typecheck/TcTyClsDecls.hs

index a9d90f2..3b19298 100644 (file)
@@ -1262,16 +1262,15 @@ tcWildCardBindersX new_wc wc_names thing_inside
 --
 -- This function does not do telescope checking.
 kcHsTyVarBndrs :: Name    -- ^ of the thing being checked
+               -> Bool    -- ^ True <=> the TyCon being kind-checked can be unsaturated
                -> Bool    -- ^ True <=> the decl being checked has a CUSK
                -> Bool    -- ^ True <=> the decl is an open type/data family
                -> Bool    -- ^ True <=> all the hsq_implicit are *kind* vars
                           -- (will give these kind * if -XNoTypeInType)
                -> LHsQTyVars Name
-               -> TcM (Kind, r)  -- ^ the result kind, possibly with other info
-               -> TcM (Bool -> TcTyCon, r)
-                     -- ^ a way to make a TcTyCon, with the other info.
-                     -- The Bool says whether the tycon can be unsaturated.
-kcHsTyVarBndrs name cusk open_fam all_kind_vars
+               -> TcM (Kind, r)     -- ^ The result kind, possibly with other info
+               -> TcM (TcTyCon, r)  -- ^ A suitably-kinded TcTyCon
+kcHsTyVarBndrs name unsat cusk open_fam all_kind_vars
   (HsQTvs { hsq_implicit = kv_ns, hsq_explicit = hs_tvs
           , hsq_dependent = dep_names }) thing_inside
   | cusk
@@ -1310,13 +1309,13 @@ kcHsTyVarBndrs name cusk open_fam all_kind_vars
 
        ; let final_binders = map (mkNamedTyConBinder Specified) good_tvs
                             ++ tc_binders
-             mk_tctc unsat = mkTcTyCon name final_binders res_kind
-                                       unsat (scoped_kvs ++ tc_tvs)
+             tycon = mkTcTyCon name final_binders res_kind
+                               unsat (scoped_kvs ++ tc_tvs)
                            -- the tvs contain the binders already
                            -- in scope from an enclosing class, but
                            -- re-adding tvs to the env't doesn't cause
                            -- harm
-       ; return ( mk_tctc, stuff ) }}
+       ; return (tycon, stuff) }}
 
   | otherwise
   = do { kv_kinds <- mk_kv_kinds
@@ -1327,9 +1326,9 @@ kcHsTyVarBndrs name cusk open_fam all_kind_vars
               bind_telescope hs_tvs thing_inside
        ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they
                -- must remain lined up with the binders
-             mk_tctc unsat = mkTcTyCon name binders res_kind unsat
-                                       (scoped_kvs ++ binderVars binders)
-       ; return (mk_tctc, stuff) }
+             tycon = mkTcTyCon name binders res_kind unsat
+                               (scoped_kvs ++ binderVars binders)
+       ; return (tycon, stuff) }
   where
       -- if -XNoTypeInType and we know all the implicits are kind vars,
       -- just give the kind *. This prevents test
index fefe1e9..0b471d2 100644 (file)
@@ -437,12 +437,11 @@ getInitialKind :: TyClDecl Name
 -- No family instances are passed to getInitialKinds
 
 getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats })
-  = do { (mk_tctc, inner_prs) <-
-           kcHsTyVarBndrs name cusk False True ktvs $
+  = do { (tycon, inner_prs) <-
+           kcHsTyVarBndrs name True cusk False True ktvs $
            do { inner_prs <- getFamDeclInitialKinds (Just cusk) ats
               ; return (constraintKind, inner_prs) }
-       ; let main_pr = mkTcTyConPair (mk_tctc True)
-       ; return (main_pr : inner_prs) }
+       ; return (mkTcTyConPair tycon : inner_prs) }
   where
     cusk = hsDeclHasCusk decl
 
@@ -450,16 +449,15 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
                               , tcdTyVars = ktvs
                               , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
                                                          , dd_cons = cons } })
-  = do  { (mk_tctc, _) <-
-           kcHsTyVarBndrs name (hsDeclHasCusk decl) False True ktvs $
+  = do  { (tycon, _) <-
+           kcHsTyVarBndrs name True (hsDeclHasCusk decl) False True ktvs $
            do { res_k <- case m_sig of
                            Just ksig -> tcLHsKind ksig
                            Nothing   -> return liftedTypeKind
               ; return (res_k, ()) }
-        ; let main_pr = mkTcTyConPair (mk_tctc True)
-              inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
+        ; let inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
                           | L _ con' <- cons, con <- getConNames con' ]
-        ; return (main_pr : inner_prs) }
+        ; return (mkTcTyConPair tycon : inner_prs) }
 
 getInitialKind (FamDecl { tcdFam = decl })
   = getFamDeclInitialKind Nothing decl
@@ -482,8 +480,8 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName     = L _ name
                                                , fdTyVars    = ktvs
                                                , fdResultSig = L _ resultSig
                                                , fdInfo      = info })
-  = do { (mk_tctc, _) <-
-           kcHsTyVarBndrs name cusk open True ktvs $
+  = do { (tycon, _) <-
+           kcHsTyVarBndrs name unsat cusk open True ktvs $
            do { res_k <- case resultSig of
                       KindSig ki                        -> tcLHsKind ki
                       TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKind ki
@@ -493,7 +491,7 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName     = L _ name
                         -- by default
                         | otherwise                -> newMetaKindVar
               ; return (res_k, ()) }
-       ; return [ mkTcTyConPair (mk_tctc unsat) ] }
+       ; return [ mkTcTyConPair tycon ] }
   where
     cusk  = famDeclHasCusk mb_cusk decl
     (open, unsat) = case info of
@@ -523,13 +521,13 @@ kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
                         , tcdRhs = rhs })
   -- Returns a possibly-unzonked kind
   = tcAddDeclCtxt decl $
-    do { (mk_tctc, _) <-
-           kcHsTyVarBndrs name (hsDeclHasCusk decl) False True hs_tvs $
+    do { (tycon, _) <-
+           kcHsTyVarBndrs name False (hsDeclHasCusk decl) False True hs_tvs $
            do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs))
               ; (_, rhs_kind) <- tcLHsType rhs
               ; traceTc "kcd2" (ppr name)
               ; return (rhs_kind, ()) }
-       ; return (mk_tctc False) }
+       ; return tycon }
 kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl)
 
 ------------------------------------------------------------------------
@@ -588,7 +586,7 @@ kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
          -- the 'False' says that the existentials don't have a CUSK, as the
          -- concept doesn't really apply here. We just need to bring the variables
          -- into scope.
-    do { _ <- kcHsTyVarBndrs (unLoc name) False False False
+    do { _ <- kcHsTyVarBndrs (unLoc name) False False False False
                              ((fromMaybe emptyLHsQTvs ex_tvs)) $
               do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)
                  ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)