import {-# SOURCE #-} TcExpr( tcCheckRho )
import HsSyn
-import TcHsSyn ( TcCmdTop, TcExpr, TcPat, mkHsLet )
+import TcHsSyn ( mkHsLet )
import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts,
TcMatchCtxt(..), tcMatchesCase )
import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo )
import TcRnMonad
import Inst ( tcSyntaxName )
+import Name ( Name )
import TysWiredIn ( boolTy, pairTyCon )
import VarSet
-import Type ( Kind,
- mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes )
-import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedHsCmdTop )
+import Type ( Kind, mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes )
+import SrcLoc ( Located(..) )
import Outputable
import Util ( lengthAtLeast )
%************************************************************************
\begin{code}
-tcProc :: RenamedPat -> RenamedHsCmdTop -- proc pat -> expr
+tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr
-> Expected TcRhoType -- Expected type of whole proc expression
- -> TcM (TcPat, TcCmdTop)
+ -> TcM (OutPat TcId, LHsCmdTop TcId)
tcProc pat cmd exp_ty
= do { arr_ty <- newTyVarTy arrowTyConKind
---------------------------------------
tcCmdTop :: CmdEnv
- -> RenamedHsCmdTop
- -> (CmdStack, TcTauType) -- Expected result type; always a monotype
+ -> LHsCmdTop Name
+ -> (CmdStack, TcTauType) -- Expected result type; always a monotype
-- We know exactly how many cmd args are expected,
-- albeit perhaps not their types; so we can pass
-- in a CmdStack
- -> TcM TcCmdTop
+ -> TcM (LHsCmdTop TcId)
-tcCmdTop env (HsCmdTop cmd _ _ names) (cmd_stk, res_ty)
- = do { cmd' <- tcCmd env cmd (cmd_stk, res_ty)
+tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) (cmd_stk, res_ty)
+ = addSrcSpan loc $
+ do { cmd' <- tcCmd env cmd (cmd_stk, res_ty)
; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
- ; return (HsCmdTop cmd' cmd_stk res_ty names') }
+ ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
----------------------------------------
-tcCmd :: CmdEnv -> RenamedHsExpr -> (CmdStack, TcTauType) -> TcM TcExpr
+tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId)
-- The main recursive function
+tcCmd env (L loc expr) res_ty
+ = addSrcSpan loc $ do
+ { expr' <- tc_cmd env expr res_ty
+ ; return (L loc expr') }
-tcCmd env (HsPar cmd) res_ty
+tc_cmd env (HsPar cmd) res_ty
= do { cmd' <- tcCmd env cmd res_ty
; return (HsPar cmd') }
-tcCmd env (HsLet binds body) res_ty
- = tcBindsAndThen HsLet binds $
- tcCmd env body res_ty
+tc_cmd env (HsLet binds (L body_loc body)) res_ty
+ = tcBindsAndThen glue binds $
+ addSrcSpan body_loc $
+ tc_cmd env body res_ty
+ where
+ glue binds expr = HsLet [binds] (L body_loc expr)
-tcCmd env in_cmd@(HsCase scrut matches src_loc) (stk, res_ty)
- = addSrcLoc src_loc $
- addErrCtxt (cmdCtxt in_cmd) $
+tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
+ = addErrCtxt (cmdCtxt in_cmd) $
tcMatchesCase match_ctxt matches (Check res_ty)
`thenM` \ (scrut_ty, matches') ->
addErrCtxt (caseScrutCtxt scrut) (
tcCheckRho scrut scrut_ty
) `thenM` \ scrut' ->
- returnM (HsCase scrut' matches' src_loc)
+ returnM (HsCase scrut' matches')
where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = mc_body }
mc_body body (Check res_ty') = tcCmd env body (stk, res_ty')
-tcCmd env (HsIf pred b1 b2 src_loc) res_ty
- = addSrcLoc src_loc $
- do { pred' <- tcCheckRho pred boolTy
+tc_cmd env (HsIf pred b1 b2) res_ty
+ = do { pred' <- tcCheckRho pred boolTy
; b1' <- tcCmd env b1 res_ty
; b2' <- tcCmd env b2 res_ty
- ; return (HsIf pred' b1' b2' src_loc)
+ ; return (HsIf pred' b1' b2')
}
-------------------------------------------
-- Arrow application
-- (f -< a) or (f =< a)
-tcCmd env cmd@(HsArrApp fun arg _ ho_app lr src_loc) (cmd_stk, res_ty)
- = addSrcLoc src_loc $
- addErrCtxt (cmdCtxt cmd) $
+tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
+ = addErrCtxt (cmdCtxt cmd) $
do { arg_ty <- newTyVarTy openTypeKind
; let fun_ty = mkCmdArrTy env arg_ty res_ty
; arg' <- tcCheckRho arg arg_ty
- ; return (HsArrApp fun' arg' fun_ty ho_app lr src_loc) }
+ ; return (HsArrApp fun' arg' fun_ty ho_app lr) }
where
-- Before type-checking f, remove the "arrow binders" from the
-- environment in the (-<) case.
-------------------------------------------
-- Command application
-tcCmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { arg_ty <- newTyVarTy openTypeKind
-------------------------------------------
-- Lambda
-tcCmd env cmd@(HsLam match@(Match pats maybe_rhs_sig grhss)) (cmd_stk, res_ty)
- = addSrcLoc (getMatchLoc match) $
- addErrCtxt (matchCtxt match_ctxt match) $
+tc_cmd env cmd@(HsLam (L mtch_loc match@(Match pats maybe_rhs_sig grhss))) (cmd_stk, res_ty)
+ = addErrCtxt (matchCtxt match_ctxt match) $
do { -- Check the cmd stack is big enough
; checkTc (lengthAtLeast cmd_stk n_pats)
; let pats_w_tys = zip pats (map Check cmd_stk)
-- Check the patterns, and the GRHSs inside
- ; (pats', grhss', ex_binds) <- tcMatchPats pats_w_tys (Check res_ty) $
+ ; (pats', grhss', ex_binds) <- addSrcSpan mtch_loc $
+ tcMatchPats pats_w_tys (Check res_ty) $
tc_grhss grhss
- ; return (HsLam (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss')))
+ ; return (HsLam (L mtch_loc (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss'))))
}
where
tc_grhss (GRHSs grhss binds _)
= tcBindsAndThen glueBindsOnGRHSs binds $
- do { grhss' <- mappM tc_grhs grhss
- ; return (GRHSs grhss' EmptyBinds res_ty) }
+ do { grhss' <- mappM (wrapLocM tc_grhs) grhss
+ ; return (GRHSs grhss' [] res_ty) }
stmt_ctxt = SC { sc_what = PatGuard match_ctxt,
sc_rhs = tcCheckRho,
sc_body = \ body -> tcCmd env body (stk', res_ty),
sc_ty = res_ty } -- ToDo: Is this right?
- tc_grhs (GRHS guarded locn)
- = addSrcLoc locn $
- do { guarded' <- tcStmts stmt_ctxt guarded
- ; return (GRHS guarded' locn) }
+ tc_grhs (GRHS guarded)
+ = do { guarded' <- tcStmts stmt_ctxt guarded
+ ; return (GRHS guarded') }
-------------------------------------------
-- Do notation
-tcCmd env cmd@(HsDo do_or_lc stmts _ ty src_loc) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsDo do_or_lc stmts _ ty) (cmd_stk, res_ty)
= do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
; stmts' <- tcStmts stmt_ctxt stmts
- ; return (HsDo do_or_lc stmts' [] res_ty src_loc) }
+ ; return (HsDo do_or_lc stmts' [] res_ty) }
-- The 'methods' needed for the HsDo are in the enclosing HsCmd
-- hence the empty list here
where
-- ----------------------------------------------
-- G |-a (| e |) c : [t1 .. tn] t
-tcCmd env cmd@(HsArrForm expr fixity cmd_args src_loc) (cmd_stk, res_ty)
- = addSrcLoc src_loc $
- addErrCtxt (cmdCtxt cmd) $
- do { cmds_w_tys <- mapM new_cmd_ty (cmd_args `zip` [1..])
+tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
+ = addErrCtxt (cmdCtxt cmd) $
+ do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
; w_tv <- newSigTyVar liftedTypeKind
; let w_ty = mkTyVarTy w_tv
-- the s1..sm and check each cmd
; cmds' <- mapM (tc_cmd w_tv') cmds_w_tys
- ; returnM (HsArrForm (TyLam [w_tv'] (mkHsLet inst_binds expr')) fixity cmds' src_loc)
+ ; returnM (HsArrForm (mkHsTyLam [w_tv'] (mkHsLet inst_binds expr')) fixity cmds')
}
where
-- Make the types
-- b, ((e,s1) .. sm), s
- new_cmd_ty :: (RenamedHsCmdTop, Int)
- -> TcM (RenamedHsCmdTop, Int, TcType, TcType, TcType)
- new_cmd_ty (cmd,i)
+ new_cmd_ty :: LHsCmdTop Name -> Int
+ -> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
+ new_cmd_ty cmd i
= do { b_ty <- newTyVarTy arrowTyConKind
; tup_ty <- newTyVarTy liftedTypeKind
-- We actually make a type variable for the tuple
-- Base case for illegal commands
-- This is where expressions that aren't commands get rejected
-tcCmd env cmd _
+tc_cmd env cmd _
= failWithTc (vcat [ptext SLIT("The expression"), nest 2 (ppr cmd),
ptext SLIT("was found where an arrow command was expected")])
\end{code}
\begin{code}
-glueBindsOnCmd EmptyBinds cmd = cmd
-glueBindsOnCmd binds (HsCmdTop cmd stk res_ty names) = HsCmdTop (HsLet binds cmd) stk res_ty names
+glueBindsOnCmd binds (L loc (HsCmdTop cmd stk res_ty names))
+ = L loc (HsCmdTop (L loc (HsLet [binds] cmd)) stk res_ty names)
-- Existential bindings become local bindings in the command
projects / ghc-hetmet.git / blobdiff