checker.
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module TcHsSyn (
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit, mkVanillaTuplePat,
+ nlHsIntLit,
+ shortCutLit, hsOverLitName,
- mkArbitraryType, -- Put this elsewhere?
-
-- re-exported from TcMonad
TcId, TcIdSet, TcDictBinds,
import Id
import TcRnMonad
-import Type
+import PrelNames
import TcType
import TcMType
import TysPrim
import TysWiredIn
-import TyCon
+import DataCon
import Name
import Var
import VarSet
import VarEnv
+import Literal
import BasicTypes
import Maybes
-import Unique
import SrcLoc
import Util
import Bag
import Outputable
\end{code}
+\begin{code}
+-- XXX
+thenM :: Monad a => a b -> (b -> a c) -> a c
+thenM = (>>=)
+
+thenM_ :: Monad a => a b -> a c -> a c
+thenM_ = (>>)
+
+returnM :: Monad m => a -> m a
+returnM = return
+
+mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
+mappM = mapM
+\end{code}
+
%************************************************************************
%* *
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
then something is wrong.
\begin{code}
-mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
--- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box
- = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))
-
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat
-hsPatType (ParPat pat) = hsLPatType pat
-hsPatType (WildPat ty) = ty
-hsPatType (VarPat var) = idType var
-hsPatType (VarPatOut var _) = idType var
-hsPatType (BangPat pat) = hsLPatType pat
-hsPatType (LazyPat pat) = hsLPatType pat
-hsPatType (LitPat lit) = hsLitType lit
-hsPatType (AsPat var pat) = idType (unLoc var)
-hsPatType (ViewPat expr pat ty) = ty
-hsPatType (ListPat _ ty) = mkListTy ty
-hsPatType (PArrPat _ ty) = mkPArrTy ty
-hsPatType (TuplePat pats box ty) = ty
-hsPatType (ConPatOut{ pat_ty = ty })= ty
-hsPatType (SigPatOut pat ty) = ty
-hsPatType (NPat lit _ _) = overLitType lit
-hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
-hsPatType (CoPat _ _ ty) = ty
+hsPatType :: Pat Id -> Type
+hsPatType (ParPat pat) = hsLPatType pat
+hsPatType (WildPat ty) = ty
+hsPatType (VarPat var) = idType var
+hsPatType (VarPatOut var _) = idType var
+hsPatType (BangPat pat) = hsLPatType pat
+hsPatType (LazyPat pat) = hsLPatType pat
+hsPatType (LitPat lit) = hsLitType lit
+hsPatType (AsPat var _) = idType (unLoc var)
+hsPatType (ViewPat _ _ ty) = ty
+hsPatType (ListPat _ ty) = mkListTy ty
+hsPatType (PArrPat _ ty) = mkPArrTy ty
+hsPatType (TuplePat _ _ ty) = ty
+hsPatType (ConPatOut { pat_ty = ty }) = ty
+hsPatType (SigPatOut _ ty) = ty
+hsPatType (NPat lit _ _) = overLitType lit
+hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
+hsPatType (CoPat _ _ ty) = ty
+hsPatType p = pprPanic "hsPatType" (ppr p)
hsLitType :: HsLit -> TcType
-hsLitType (HsChar c) = charTy
-hsLitType (HsCharPrim c) = charPrimTy
-hsLitType (HsString str) = stringTy
-hsLitType (HsStringPrim s) = addrPrimTy
-hsLitType (HsInt i) = intTy
-hsLitType (HsIntPrim i) = intPrimTy
-hsLitType (HsInteger i ty) = ty
-hsLitType (HsRat _ ty) = ty
-hsLitType (HsFloatPrim f) = floatPrimTy
-hsLitType (HsDoublePrim d) = doublePrimTy
+hsLitType (HsChar _) = charTy
+hsLitType (HsCharPrim _) = charPrimTy
+hsLitType (HsString _) = stringTy
+hsLitType (HsStringPrim _) = addrPrimTy
+hsLitType (HsInt _) = intTy
+hsLitType (HsIntPrim _) = intPrimTy
+hsLitType (HsWordPrim _) = wordPrimTy
+hsLitType (HsInteger _ ty) = ty
+hsLitType (HsRat _ ty) = ty
+hsLitType (HsFloatPrim _) = floatPrimTy
+hsLitType (HsDoublePrim _) = doublePrimTy
\end{code}
+Overloaded literals. Here mainly becuase it uses isIntTy etc
+
+\begin{code}
+shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId)
+shortCutLit (HsIntegral i) ty
+ | isIntTy ty && inIntRange i = Just (HsLit (HsInt i))
+ | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
+ | isIntegerTy ty = Just (HsLit (HsInteger i ty))
+ | otherwise = shortCutLit (HsFractional (fromInteger i)) ty
+ -- The 'otherwise' case is important
+ -- Consider (3 :: Float). Syntactically it looks like an IntLit,
+ -- so we'll call shortCutIntLit, but of course it's a float
+ -- This can make a big difference for programs with a lot of
+ -- literals, compiled without -O
+
+shortCutLit (HsFractional f) ty
+ | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f))
+ | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
+ | otherwise = Nothing
+
+shortCutLit (HsIsString s) ty
+ | isStringTy ty = Just (HsLit (HsString s))
+ | otherwise = Nothing
+
+mkLit :: DataCon -> HsLit -> HsExpr Id
+mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
+
+------------------------------
+hsOverLitName :: OverLitVal -> Name
+-- Get the canonical 'fromX' name for a particular OverLitVal
+hsOverLitName (HsIntegral {}) = fromIntegerName
+hsOverLitName (HsFractional {}) = fromRationalName
+hsOverLitName (HsIsString {}) = fromStringName
+\end{code}
%************************************************************************
%* *
-- Maps an Id to its zonked version; both have the same Name
-- Is only consulted lazily; hence knot-tying
+emptyZonkEnv :: ZonkEnv
emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
--
-- Even without template splices, in module Main, the checking of
-- 'main' is done as a separate chunk.
-zonkIdOcc (ZonkEnv zonk_ty env) id
+zonkIdOcc (ZonkEnv _zonk_ty env) id
| isLocalVar id = lookupVarEnv env id `orElse` id
| otherwise = id
+zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
zonkIdOccs env ids = map (zonkIdOcc env) ids
-- zonkIdBndr is used *after* typechecking to get the Id's type
-- "Dictionary" binders can be coercion variables or dictionary variables
zonkDictBndrs env ids = mappM (zonkDictBndr env) ids
-zonkDictBndr env var | isTyVar var = return var
+zonkDictBndr :: ZonkEnv -> Var -> TcM Var
+zonkDictBndr env var | isTyVar var = zonkTyVarBndr env var
| otherwise = zonkIdBndr env var
zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
+
+-- Zonk the kind of a non-TC tyvar in case it is a coercion variable (their
+-- kind contains types).
+--
+zonkTyVarBndr :: ZonkEnv -> TyVar -> TcM TyVar
+zonkTyVarBndr env tv
+ | isCoVar tv
+ = do { kind <- zonkTcTypeToType env (tyVarKind tv)
+ ; return $ setTyVarKind tv kind
+ }
+ | otherwise = return tv
\end{code}
---------------------------------------------
zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
-zonkValBinds env bs@(ValBindsIn _ _)
- = panic "zonkValBinds" -- Not in typechecker output
+zonkValBinds _ (ValBindsIn _ _)
+ = panic "zonkValBinds" -- Not in typechecker output
zonkValBinds env (ValBindsOut binds sigs)
= do { (env1, new_binds) <- go env binds
; return (env1, ValBindsOut new_binds sigs) }
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds
= fixM (\ ~(_, new_binds) -> do
- { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
+ { let env1 = extendZonkEnv env (collectHsBindsBinders new_binds)
; binds' <- zonkMonoBinds env1 binds
; return (env1, binds') })
; new_ty <- zonkTcTypeToType env ty
; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
-zonk_bind env (VarBind { var_id = var, var_rhs = expr })
+zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
= zonkIdBndr env var `thenM` \ new_var ->
zonkLExpr env expr `thenM` \ new_expr ->
- returnM (VarBind { var_id = new_var, var_rhs = new_expr })
+ returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl })
zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
= wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
fixM (\ ~(new_val_binds, _) ->
let
env1 = extendZonkEnv env new_dicts
- env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
+ env2 = extendZonkEnv env1 (collectHsBindsBinders new_val_binds)
in
zonkMonoBinds env2 val_binds `thenM` \ new_val_binds ->
mappM (zonkExport env2) exports `thenM` \ new_exports ->
zonkExport env (tyvars, global, local, prags)
-- The tyvars are already zonked
= zonkIdBndr env global `thenM` \ new_global ->
- mapM zonk_prag prags `thenM` \ new_prags ->
+ zonk_prags prags `thenM` \ new_prags ->
returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
- zonk_prag prag@(L _ (InlinePrag {})) = return prag
- zonk_prag (L loc (SpecPrag expr ty ds inl))
- = do { expr' <- zonkExpr env expr
- ; ty' <- zonkTcTypeToType env ty
- ; let ds' = zonkIdOccs env ds
- ; return (L loc (SpecPrag expr' ty' ds' inl)) }
+
+ zonk_prags IsDefaultMethod = return IsDefaultMethod
+ zonk_prags (SpecPrags ps) = do { ps' <- mapM zonk_prag ps; return (SpecPrags ps') }
+
+ zonk_prag (L loc (SpecPrag co_fn inl))
+ = do { (_, co_fn') <- zonkCoFn env co_fn
+ ; return (L loc (SpecPrag co_fn' inl)) }
\end{code}
%************************************************************************
= zonkTcTypeToType env ty `thenM` \ new_ty ->
returnM (HsLit (HsRat f new_ty))
-zonkExpr env (HsLit lit)
+zonkExpr _ (HsLit lit)
= returnM (HsLit lit)
zonkExpr env (HsOverLit lit)
zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
returnM (n,e')
-zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
+zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
returnM (HsSpliceE s)
zonkExpr env (OpApp e1 op fixity e2)
zonkLExpr env expr `thenM` \ new_expr ->
returnM (SectionR new_op new_expr)
+zonkExpr env (ExplicitTuple tup_args boxed)
+ = do { new_tup_args <- mapM zonk_tup_arg tup_args
+ ; return (ExplicitTuple new_tup_args boxed) }
+ where
+ zonk_tup_arg (Present e) = do { e' <- zonkLExpr env e; return (Present e') }
+ zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }
+
zonkExpr env (HsCase expr ms)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkMatchGroup env ms `thenM` \ new_ms ->
zonkLExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitPArr new_ty new_exprs)
-zonkExpr env (ExplicitTuple exprs boxed)
- = zonkLExprs env exprs `thenM` \ new_exprs ->
- returnM (ExplicitTuple new_exprs boxed)
-
zonkExpr env (RecordCon data_con con_expr rbinds)
= do { new_con_expr <- zonkExpr env con_expr
; new_rbinds <- zonkRecFields env rbinds
= do { e' <- zonkLExpr env e
; return (ExprWithTySigOut e' ty) }
-zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
+zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
zonkExpr env (ArithSeq expr info)
= zonkExpr env expr `thenM` \ new_expr ->
zonkExpr env1 expr `thenM` \ new_expr ->
return (HsWrap new_co_fn new_expr)
-zonkExpr env other = pprPanic "zonkExpr" (ppr other)
+zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
+zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
= zonkLExpr env cmd `thenM` \ new_cmd ->
zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
-------------------------------------------------------------------------
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn env WpHole = return (env, WpHole)
-zonkCoFn env WpInline = return (env, WpInline)
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
; (env2, c2') <- zonkCoFn env1 c2
; return (env2, WpCompose c1' c2') }
-zonkCoFn env (WpCo co) = do { co' <- zonkTcTypeToType env co
- ; return (env, WpCo co') }
-zonkCoFn env (WpLam id) = do { id' <- zonkIdBndr env id
+zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co
+ ; return (env, WpCast co') }
+zonkCoFn env (WpLam id) = do { id' <- zonkDictBndr env id
; let env1 = extendZonkEnv1 env id'
; return (env1, WpLam id') }
zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
- do { return (env, WpTyLam tv) }
-zonkCoFn env (WpApp id) = do { return (env, WpApp (zonkIdOcc env id)) }
+ do { tv' <- zonkTyVarBndr env tv
+ ; return (env, WpTyLam tv') }
+zonkCoFn env (WpApp v)
+ | isTcTyVar v = do { co <- zonkTcTyVar v
+ ; return (env, WpTyApp co) }
+ -- Yuk! A mutable coercion variable is a TcTyVar
+ -- not a CoVar, so don't use isCoVar!
+ -- Yuk! A WpApp can't hold the zonked type,
+ -- so we switch to WpTyApp
+ | otherwise = return (env, WpApp (zonkIdOcc env v))
zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
; return (env, WpTyApp ty') }
zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs
zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
-- Only used for 'do', so the only Ids are in a MDoExpr table
zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
-zonkDo env do_or_lc = do_or_lc
+zonkDo _ do_or_lc = do_or_lc
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
-zonkOverLit env ol =
- let
- zonkedStuff = do ty' <- zonkTcTypeToType env (overLitType ol)
- e' <- zonkExpr env (overLitExpr ol)
- return (e', ty')
- ru f (x, y) = return (f x y)
- in
- case ol of
- (HsIntegral i _ _) -> ru (HsIntegral i) =<< zonkedStuff
- (HsFractional r _ _) -> ru (HsFractional r) =<< zonkedStuff
- (HsIsString s _ _) -> ru (HsIsString s) =<< zonkedStuff
+zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
+ = do { ty' <- zonkTcTypeToType env ty
+ ; e' <- zonkExpr env e
+ ; return (lit { ol_witness = e', ol_type = ty' }) }
-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
returnM (new_stmts, zonkIdOccs env1 bndrs)
-zonkStmt env (RecStmt segStmts lvs rvs rets binds)
- = zonkIdBndrs env rvs `thenM` \ new_rvs ->
- let
- env1 = extendZonkEnv env new_rvs
- in
- zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
+zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
+ , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
+ , recS_rec_rets = rets, recS_dicts = binds })
+ = do { new_rvs <- zonkIdBndrs env rvs
+ ; new_lvs <- zonkIdBndrs env lvs
+ ; new_ret_id <- zonkExpr env ret_id
+ ; new_mfix_id <- zonkExpr env mfix_id
+ ; new_bind_id <- zonkExpr env bind_id
+ ; let env1 = extendZonkEnv env new_rvs
+ ; (env2, new_segStmts) <- zonkStmts env1 segStmts
-- Zonk the ret-expressions in an envt that
-- has the polymorphic bindings in the envt
- mapM (zonkExpr env2) rets `thenM` \ new_rets ->
- let
- new_lvs = zonkIdOccs env2 lvs
- env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
- in
- zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
- returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
+ ; new_rets <- mapM (zonkExpr env2) rets
+ ; let env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
+ ; (env4, new_binds) <- zonkRecMonoBinds env3 binds
+ ; return (env4,
+ RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
+ , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
+ , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
+ , recS_rec_rets = new_rets, recS_dicts = new_binds }) }
zonkStmt env (ExprStmt expr then_op ty)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
returnM (env, ExprStmt new_expr new_then new_ty)
+zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr)
+ = do { (env', stmts') <- zonkStmts env stmts
+ ; let binders' = zonkIdOccs env' binders
+ ; usingExpr' <- zonkLExpr env' usingExpr
+ ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
+ ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') }
+
+zonkStmt env (GroupStmt stmts binderMap by using)
+ = do { (env', stmts') <- zonkStmts env stmts
+ ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
+ ; by' <- fmapMaybeM (zonkLExpr env') by
+ ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
+ ; let env'' = extendZonkEnv env' (map snd binderMap')
+ ; return (env'', GroupStmt stmts' binderMap' by' using') }
+ where
+ zonkBinderMapEntry env (oldBinder, newBinder) = do
+ let oldBinder' = zonkIdOcc env oldBinder
+ newBinder' <- zonkIdBndr env newBinder
+ return (oldBinder', newBinder')
+
zonkStmt env (LetStmt binds)
= zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
returnM (env1, LetStmt new_binds)
; new_fail <- zonkExpr env fail_op
; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
+zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id))
+zonkMaybeLExpr _ Nothing = return Nothing
+zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
+
-------------------------------------------------------------------------
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
; return (HsRecFields flds' dd) }
where
zonk_rbind fld
- = do { new_expr <- zonkLExpr env (hsRecFieldArg fld)
- ; return (fld { hsRecFieldArg = new_expr }) }
- -- Field selectors have declared types; hence no zonking
+ = do { new_id <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
+ ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+ ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
-------------------------------------------------------------------------
mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
-- to the right)
zonkPat env pat = wrapLocSndM (zonk_pat env) pat
+zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
zonk_pat env (ParPat p)
= do { (env', p') <- zonkPat env p
; return (env', ParPat p') }
zonk_pat env (ViewPat expr pat ty)
= do { expr' <- zonkLExpr env expr
; (env', pat') <- zonkPat env pat
- ; return (env', ViewPat expr' pat' ty) }
+ ; ty' <- zonkTcTypeToType env ty
+ ; return (env', ViewPat expr' pat' ty') }
zonk_pat env (ListPat pats ty)
= do { ty' <- zonkTcTypeToType env ty
zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
= ASSERT( all isImmutableTyVar (pat_tvs p) )
do { new_ty <- zonkTcTypeToType env ty
- ; new_dicts <- zonkIdBndrs env dicts
+ ; new_dicts <- zonkDictBndrs env dicts
; let env1 = extendZonkEnv env new_dicts
; (env2, new_binds) <- zonkRecMonoBinds env1 binds
; (env', new_args) <- zonkConStuff env2 args
; ty' <- zonkTcTypeToType env'' ty
; return (env'', CoPat co_fn' (unLoc pat') ty') }
-zonk_pat env pat = pprPanic "zonk_pat" (ppr pat)
+zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
---------------------------
+zonkConStuff :: ZonkEnv
+ -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))
+ -> TcM (ZonkEnv,
+ HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
zonkConStuff env (PrefixCon pats)
= do { (env', pats') <- zonkPats env pats
; return (env', PrefixCon pats') }
-- Field selectors have declared types; hence no zonking
---------------------------
+zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
zonkPats env [] = return (env, [])
zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
; (env', pats') <- zonkPats env1 pats
zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
-zonkForeignExport env (ForeignExport i hs_ty spec) =
+zonkForeignExport env (ForeignExport i _hs_ty spec) =
returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
-zonkForeignExport env for_imp
+zonkForeignExport _ for_imp
= returnM for_imp -- Foreign imports don't need zonking
\end{code}
zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
-zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs fv_lhs rhs fv_rhs)
+zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
= mappM zonk_bndr vars `thenM` \ new_bndrs ->
newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
let
| isId (unLoc v) = wrapLocM (zonkIdBndr env) v
| otherwise = ASSERT( isImmutableTyVar (unLoc v) )
return v
+ zonk_bndr (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
\end{code}
-- mutable tyvar to a fresh immutable one. So the mutable store
-- plays the role of an environment. If we come across a mutable
-- type variable that isn't so bound, it must be completely free.
- zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty }
- where
- ty = mkArbitraryType tv
-
-
--- When the type checker finds a type variable with no binding,
--- which means it can be instantiated with an arbitrary type, it
--- usually instantiates it to Void. Eg.
---
--- length []
--- ===>
--- length Void (Nil Void)
---
--- But in really obscure programs, the type variable might have
--- a kind other than *, so we need to invent a suitably-kinded type.
---
--- This commit uses
--- Void for kind *
--- List for kind *->*
--- Tuple for kind *->...*->*
---
--- which deals with most cases. (Previously, it only dealt with
--- kind *.)
---
--- In the other cases, it just makes up a TyCon with a suitable
--- kind. If this gets into an interface file, anyone reading that
--- file won't understand it. This is fixable (by making the client
--- of the interface file make up a TyCon too) but it is tiresome and
--- never happens, so I am leaving it
-
-mkArbitraryType :: TcTyVar -> Type
--- Make up an arbitrary type whose kind is the same as the tyvar.
--- We'll use this to instantiate the (unbound) tyvar.
-mkArbitraryType tv
- | liftedTypeKind `isSubKind` kind = anyPrimTy -- The vastly common case
- | otherwise = mkTyConApp tycon []
- where
- kind = tyVarKind tv
- (args,res) = splitKindFunTys kind
-
- tycon | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
- = anyPrimTyCon1 -- No tuples this size
-
- | all isLiftedTypeKind args && isLiftedTypeKind res
- = tupleTyCon Boxed (length args) -- *-> ... ->*->*
- -- Horrible hack to make less use of mkAnyPrimTyCon
-
- | otherwise
- = mkAnyPrimTyCon (getUnique tv) kind
- -- Same name as the tyvar, apart from making it start with a colon (sigh)
- -- I dread to think what will happen if this gets out into an
- -- interface file. Catastrophe likely. Major sigh.
-\end{code}
+ zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
+ ; writeMetaTyVar tv ty
+ ; return ty }
+\end{code}
\ No newline at end of file
projects / ghc-hetmet.git / blobdiff