[Git][ghc/ghc][wip/amg/hasfield-2020] 2 commits: Return [FamInst] rather than representation tycons from tcInstDecls1
Adam Gundry
gitlab at gitlab.haskell.org
Mon Sep 21 09:11:39 UTC 2020
Adam Gundry pushed to branch wip/amg/hasfield-2020 at Glasgow Haskell Compiler / GHC
Commits:
f27a94c7 by Adam Gundry at 2020-09-21T09:30:23+01:00
Return [FamInst] rather than representation tycons from tcInstDecls1
- - - - -
bca7c799 by Adam Gundry at 2020-09-21T10:10:59+01:00
Refactor: move addClsInsts and addFamInsts out of tcInstDecls1
Also modify addTyConsToGblEnv to use the thing_inside pattern
- - - - -
6 changed files:
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/Instance.hs-boot
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
Changes:
=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -238,8 +238,7 @@ tcDeriving deriv_infos deriv_decls
FormatHaskell
(ddump_deriving inst_info rn_binds famInsts))
- ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))
- getGblEnv
+ ; gbl_env <- addClsInsts (bagToList inst_info) getGblEnv
; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)
; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }
where
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -38,6 +38,7 @@ import GHC.Tc.TyCl.Utils
import GHC.Tc.TyCl.Class
import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 )
import GHC.Tc.Deriv (DerivInfo(..))
+import GHC.Tc.Utils.Instantiate ( addClsInsts )
import GHC.Tc.Utils.Unify ( checkTvConstraints )
import GHC.Tc.Gen.HsType
import GHC.Tc.Instance.Class( AssocInstInfo(..) )
@@ -195,19 +196,20 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
-- Step 3: Add the implicit things;
-- we want them in the environment because
-- they may be mentioned in interface files
- ; gbl_env <- addTyConsToGblEnv tyclss
+ ; addTyConsToGblEnv tyclss $ do {
-- Step 4: check instance declarations
- ; (gbl_env', inst_info, datafam_deriv_info, data_rep_tycons) <-
- setGblEnv gbl_env $
- tcInstDecls1 instds
+ ; (inst_info, fam_insts, datafam_deriv_info) <- tcInstDecls1 instds
+ ; addClsInsts inst_info $
+ addFamInsts fam_insts $ do {
-- Step 5: build record selectors/updaters, don't type-check them yet
-- See Note [Calling tcRecSelBinds] in GHC.Tc.TyCl.Utils
- ; rec_sel_upd_binds <- mkRecSelBinds (tyclss ++ data_rep_tycons)
+ ; rec_sel_upd_binds <- mkRecSelBinds (tyclss ++ famInstsRepTyCons fam_insts)
+ ; gbl_env' <- getGblEnv
; let deriv_info = datafam_deriv_info ++ data_deriv_info
- ; return (gbl_env', inst_info, deriv_info, rec_sel_upd_binds) }
+ ; return (gbl_env', inst_info, deriv_info, rec_sel_upd_binds) }}}
-- Gives the kind for every TyCon that has a standalone kind signature
type KindSigEnv = NameEnv Kind
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -26,7 +26,6 @@ import GHC.Prelude
import GHC.Hs
import GHC.Tc.Gen.Bind
import GHC.Tc.TyCl
-import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv )
import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault,
HsSigFun, mkHsSigFun, badMethodErr,
findMethodBind, instantiateMethod )
@@ -379,28 +378,18 @@ Gather up the instance declarations from their various sources
tcInstDecls1 -- Deal with both source-code and imported instance decls
:: [LInstDecl GhcRn] -- Source code instance decls
- -> TcM (TcGblEnv, -- The full inst env
- [InstInfo GhcRn], -- Source-code instance decls to process;
+ -> TcM ([InstInfo GhcRn], -- Source-code instance decls to process;
-- contains all dfuns for this module
- [DerivInfo], -- From data family instances
- [TyCon]) -- Data family instance representation tycons
+ [FamInst], -- Family instances
+ [DerivInfo]) -- From data family instances
tcInstDecls1 inst_decls
= do { -- Do class and family instance declarations
; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
-
- ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff
- fam_insts = concat fam_insts_s
- local_infos = concat local_infos_s
-
- ; (data_rep_tycons, gbl_env) <- addClsInsts local_infos $
- addFamInsts fam_insts $
- getGblEnv
-
- ; return ( gbl_env
- , local_infos
- , concat datafam_deriv_infos
- , data_rep_tycons ) }
+ ; let (local_infos_s, fam_insts_s, datafam_deriv_infos_s) = unzip3 stuff
+ ; return ( concat local_infos_s
+ , concat fam_insts_s
+ , concat datafam_deriv_infos_s ) }
-- | Use DerivInfo for data family instances (produced by tcInstDecls1),
-- datatype declarations (TyClDecl), and standalone deriving declarations
@@ -417,28 +406,6 @@ tcInstDeclsDeriv deriv_infos derivds
else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds
; return (tcg_env, bagToList info_bag, valbinds) }
-addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
-addClsInsts infos thing_inside
- = tcExtendLocalInstEnv (map iSpec infos) thing_inside
-
-addFamInsts :: [FamInst] -> TcM a -> TcM ([TyCon], a)
--- Extend (a) the family instance envt
--- (b) the type envt with stuff from data type decls
--- Additionally return the data family representation tycons
-addFamInsts fam_insts thing_inside
- = tcExtendLocalFamInstEnv fam_insts $
- tcExtendGlobalEnv axioms $
- do { traceTc "addFamInsts" (pprFamInsts fam_insts)
- ; gbl_env <- addTyConsToGblEnv data_rep_tycons
- -- Does not add its axiom; that comes
- -- from adding the 'axioms' above
- ; x <- setGblEnv gbl_env thing_inside
- ; return (data_rep_tycons, x) }
- where
- axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
- data_rep_tycons = famInstsRepTyCons fam_insts
- -- The representation tycons for 'data instances' declarations
-
{-
Note [Deriving inside TH brackets]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/TyCl/Instance.hs-boot
=====================================
@@ -5,7 +5,7 @@
module GHC.Tc.TyCl.Instance ( tcInstDecls1 ) where
-import GHC.Core.TyCon
+import GHC.Core.FamInstEnv( FamInst )
import GHC.Hs
import GHC.Tc.Types
import GHC.Tc.Utils.Env( InstInfo )
@@ -14,4 +14,4 @@ import GHC.Tc.Deriv
-- We need this because of the mutual recursion
-- between GHC.Tc.TyCl and GHC.Tc.TyCl.Instance
tcInstDecls1 :: [LInstDecl GhcRn]
- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], [TyCon])
+ -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -22,7 +22,7 @@ module GHC.Tc.TyCl.Utils(
checkClassCycles,
-- * Implicits
- addTyConsToGblEnv, mkDefaultMethodType,
+ addFamInsts, addTyConsToGblEnv, mkDefaultMethodType,
-- * Record selectors
tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector
@@ -32,6 +32,7 @@ module GHC.Tc.TyCl.Utils(
import GHC.Prelude
+import GHC.Tc.Instance.Family
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Bind( tcValBinds )
@@ -43,6 +44,7 @@ import GHC.Builtin.Types( unitTy, mkBoxedTupleTy )
import GHC.Core.Make( rEC_SEL_ERROR_ID )
import GHC.Hs
import GHC.Core.Class
+import GHC.Core.FamInstEnv
import GHC.Core.Type
import GHC.Driver.Types
import GHC.Core.TyCon
@@ -58,6 +60,7 @@ import GHC.Types.Id.Info
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Core.Coercion ( ltRole )
+import GHC.Core.Coercion.Axiom ( toBranchedAxiom )
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Unique ( mkBuiltinUnique )
@@ -750,20 +753,36 @@ updateRoleEnv name n role
* *
********************************************************************* -}
-addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv
+addFamInsts :: [FamInst] -> TcM a -> TcM a
+-- Extend (a) the family instance envt
+-- (b) the type envt with stuff from data type decls
+addFamInsts fam_insts thing_inside
+ = tcExtendLocalFamInstEnv fam_insts $
+ tcExtendGlobalEnv axioms $
+ do { traceTc "addFamInsts" (pprFamInsts fam_insts)
+ ; addTyConsToGblEnv data_rep_tycons thing_inside
+ -- Does not add its axiom; that comes
+ -- from adding the 'axioms' above
+ }
+ where
+ axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
+ data_rep_tycons = famInstsRepTyCons fam_insts
+ -- The representation tycons for 'data instances' declarations
+
+addTyConsToGblEnv :: [TyCon] -> TcM a -> TcM a
-- Given a [TyCon], add to the TcGblEnv
-- * extend the TypeEnv with the tycons
-- * extend the TypeEnv with their implicitTyThings
-- * extend the TypeEnv with any default method Ids
-- * add bindings for record selectors
-addTyConsToGblEnv tyclss
+addTyConsToGblEnv tyclss thing_inside
= tcExtendTyConEnv tyclss $
tcExtendGlobalEnvImplicit implicit_things $
tcExtendGlobalValEnv def_meth_ids $
do { traceTc "tcAddTyCons" $ vcat
[ text "tycons" <+> ppr tyclss
, text "implicits" <+> ppr implicit_things ]
- ; getGblEnv }
+ ; thing_inside }
where
implicit_things = concatMap implicitTyConThings tyclss
def_meth_ids = mkDefaultMethodIds tyclss
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -28,7 +28,7 @@ module GHC.Tc.Utils.Instantiate (
newClsInst,
tcGetInsts, tcGetInstEnvs, getOverlapFlag,
- tcExtendLocalInstEnv,
+ addClsInsts,
instCallConstraints, newMethodFromName,
tcSyntaxName,
@@ -846,6 +846,10 @@ instOrphWarn inst
text "wrap the type with a newtype and declare the instance on the new type." :
[]
+addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
+addClsInsts infos thing_inside
+ = tcExtendLocalInstEnv (map iSpec infos) thing_inside
+
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
-- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a943914b0cc0c9a399bd575651a2ba4ab9375ae8...bca7c7995cc382c82d5286353470398bfb6b2200
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a943914b0cc0c9a399bd575651a2ba4ab9375ae8...bca7c7995cc382c82d5286353470398bfb6b2200
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200921/53a47e6c/attachment-0001.html>
More information about the ghc-commits
mailing list