-tcSpecSigs :: [LSig Name] -> TcM (LHsBinds TcId)
-tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : sigs)
- = -- SPECIALISE f :: forall b. theta => tau = g
- setSrcSpan loc $
- addErrCtxt (valSpecSigCtxt name poly_ty) $
-
- -- Get and instantiate its alleged specialised type
- tcHsSigType (FunSigCtxt name) poly_ty `thenM` \ sig_ty ->
-
- -- Check that f has a more general type, and build a RHS for
- -- the spec-pragma-id at the same time
- getLIE (tcCheckSigma (L nm_loc (HsVar name)) sig_ty) `thenM` \ (spec_expr, spec_lie) ->
-
- -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
- tcSimplifyToDicts spec_lie `thenM` \ spec_binds ->
-
- -- Just specialise "f" by building a SpecPragmaId binding
- -- It is the thing that makes sure we don't prematurely
- -- dead-code-eliminate the binding we are really interested in.
- newLocalName name `thenM` \ spec_name ->
- let
- spec_bind = VarBind (mkSpecPragmaId spec_name sig_ty)
- (mkHsLet spec_binds spec_expr)
- in
+type TcSigFun = Name -> Maybe (LSig Name)
+
+mkSigFun :: [LSig Name] -> TcSigFun
+-- Search for a particular type signature
+-- Precondition: the sigs are all type sigs
+-- Precondition: no duplicates
+mkSigFun sigs = lookupNameEnv env
+ where
+ env = mkNameEnv [(expectJust "mkSigFun" (sigName sig), sig) | sig <- sigs]
+
+---------------
+data TcSigInfo
+ = TcSigInfo {
+ sig_id :: TcId, -- *Polymorphic* binder for this value...
+
+ sig_scoped :: [Name], -- Names for any scoped type variables
+ -- Invariant: correspond 1-1 with an initial
+ -- segment of sig_tvs (see Note [Scoped])
+
+ sig_tvs :: [TcTyVar], -- Instantiated type variables
+ -- See Note [Instantiate sig]
+
+ sig_theta :: TcThetaType, -- Instantiated theta
+ sig_tau :: TcTauType, -- Instantiated tau
+ sig_loc :: InstLoc -- The location of the signature
+ }
+
+-- Note [Scoped]
+-- There may be more instantiated type variables than scoped
+-- ones. For example:
+-- type T a = forall b. b -> (a,b)
+-- f :: forall c. T c
+-- Here, the signature for f will have one scoped type variable, c,
+-- but two instantiated type variables, c' and b'.
+--
+-- We assume that the scoped ones are at the *front* of sig_tvs,
+-- and remember the names from the original HsForAllTy in sig_scoped
+
+-- Note [Instantiate sig]
+-- It's vital to instantiate a type signature with fresh variable.
+-- For example:
+-- type S = forall a. a->a
+-- f,g :: S
+-- f = ...
+-- g = ...
+-- Here, we must use distinct type variables when checking f,g's right hand sides.
+-- (Instantiation is only necessary because of type synonyms. Otherwise,
+-- it's all cool; each signature has distinct type variables from the renamer.)
+
+instance Outputable TcSigInfo where
+ ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
+ = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
+\end{code}
+
+\begin{code}
+tcTySig :: LSig Name -> TcM TcId
+tcTySig (L span (TypeSig (L _ name) ty))
+ = setSrcSpan span $
+ do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+ ; return (mkLocalId name sigma_ty) }
+
+-------------------
+tcInstSig_maybe :: Maybe (LSig Name) -> TcM (Maybe TcSigInfo)
+-- Instantiate with *meta* type variables;
+-- this signature is part of a multi-signature group
+tcInstSig_maybe Nothing = return Nothing
+tcInstSig_maybe (Just sig) = do { tc_sig <- tcInstSig False sig
+ ; return (Just tc_sig) }
+
+tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo
+-- Instantiate the signature, with either skolems or meta-type variables
+-- depending on the use_skols boolean
+--
+-- We always instantiate with freshs uniques,
+-- although we keep the same print-name
+--
+-- type T = forall a. [a] -> [a]
+-- f :: T;
+-- f = g where { g :: T; g = <rhs> }
+--
+-- We must not use the same 'a' from the defn of T at both places!!
+
+tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty))
+ = setSrcSpan loc $
+ do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into
+ -- scope when starting the binding group
+ ; let skol_info = SigSkol (FunSigCtxt name)
+ inst_tyvars | use_skols = tcInstSkolTyVars skol_info
+ | otherwise = tcInstSigTyVars skol_info
+ ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id)
+ ; loc <- getInstLoc (SigOrigin skol_info)
+ ; return (TcSigInfo { sig_id = poly_id,
+ sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
+ sig_scoped = scoped_names, sig_loc = loc }) }
+ -- Note that the scoped_names and the sig_tvs will have
+ -- different Names. That's quite ok; when we bring the
+ -- scoped_names into scope, we just bind them to the sig_tvs
+ where
+ -- The scoped names are the ones explicitly mentioned
+ -- in the HsForAll. (There may be more in sigma_ty, because
+ -- of nested type synonyms. See Note [Scoped] with TcSigInfo.)
+ -- We also only have scoped type variables when we are instantiating
+ -- with true skolems
+ scoped_names = case (use_skols, hs_ty) of
+ (True, L _ (HsForAllTy Explicit tvs _ _)) -> hsLTyVarNames tvs
+ other -> []
+
+-------------------
+isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool
+isUnRestrictedGroup binds sig_fn
+ = do { mono_restriction <- doptM Opt_MonomorphismRestriction
+ ; return (not mono_restriction || all_unrestricted) }
+ where
+ all_unrestricted = all (unrestricted . unLoc) binds
+ has_sig n = isJust (sig_fn n)
projects / ghc-hetmet.git / blobdiff