-tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
-tcUserStmt (L loc (ExprStmt expr _ _))
- = newUnique `thenM` \ uniq ->
- let
- fresh_it = itName uniq
- the_bind = noLoc $ FunBind (noLoc fresh_it) False
- (mkMatchGroup [mkSimpleMatch [] expr])
- in
- tryTcLIE_ (do { -- Try this if the other fails
- traceTc (text "tcs 1b") ;
- tc_stmts (map (L loc) [
- LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
- ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
- (HsVar thenIOName) placeHolderType
- ]) })
- (do { -- Try this first
- traceTc (text "tcs 1a") ;
- tc_stmts [L loc (BindStmt (nlVarPat fresh_it) expr
- (HsVar bindIOName) noSyntaxExpr) ] })
-
-tcUserStmt stmt = tc_stmts [stmt]
+type PlanResult = ([Id], LHsExpr Id)
+type Plan = TcM PlanResult
+
+runPlans :: [Plan] -> TcM PlanResult
+-- Try the plans in order. If one fails (by raising an exn), try the next.
+-- If one succeeds, take it.
+runPlans [] = panic "runPlans"
+runPlans [p] = p
+runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
+
+--------------------
+mkPlan :: LStmt Name -> TcM PlanResult
+mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
+ = do { uniq <- newUnique -- is treated very specially
+ ; let fresh_it = itName uniq
+ the_bind = L loc $ FunBind (L loc fresh_it) False matches emptyNameSet
+ matches = mkMatchGroup [mkMatch [] expr emptyLocalBinds]
+ let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
+ bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
+ (HsVar bindIOName) noSyntaxExpr
+ print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
+ (HsVar thenIOName) placeHolderType
+
+ -- The plans are:
+ -- [it <- e; print it] but not if it::()
+ -- [it <- e]
+ -- [let it = e; print it]
+ ; runPlans [ -- Plan A
+ do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
+ ; it_ty <- zonkTcType (idType it_id)
+ ; ifM (isUnitTy it_ty) failM
+ ; return stuff },
+
+ -- Plan B; a naked bind statment
+ tcGhciStmts [bind_stmt],
+
+ -- Plan C; check that the let-binding is typeable all by itself.
+ -- If not, fail; if so, try to print it.
+ -- The two-step process avoids getting two errors: one from
+ -- the expression itself, and one from the 'print it' part
+ -- This two-step story is very clunky, alas
+ do { checkNoErrs (tcGhciStmts [let_stmt])
+ --- checkNoErrs defeats the error recovery of let-bindings
+ ; tcGhciStmts [let_stmt, print_it] }
+ ]}
+
+mkPlan stmt@(L loc (BindStmt {}))
+ | [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt
+ = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
+ (HsVar thenIOName) placeHolderType
+ -- The plans are:
+ -- [stmt; print v] but not if v::()
+ -- [stmt]
+ ; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
+ ; v_ty <- zonkTcType (idType v_id)
+ ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
+ ; return stuff },
+ tcGhciStmts [stmt]
+ ]}
+
+mkPlan stmt
+ = tcGhciStmts [stmt]