| ... |
... |
@@ -2042,35 +2042,33 @@ generateMainBinding tcg_env main_name = do |
|
2042
|
2042
|
-- https://github.com/ghc-proposals/ghc-proposals/pull/771.
|
|
2043
|
2043
|
handleMainReturn :: Name -> TcType -> TcEvBinds -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
|
|
2044
|
2044
|
handleMainReturn main_name res_ty ev_binds main_expr = do
|
|
2045
|
|
- meaningful_main <- xoptM LangExt.MeaningfulMainReturn
|
|
2046
|
|
- void_ty <- mkTyConTy <$> tcLookupKnownOccTyCon voidTyConOcc
|
|
2047
|
|
- exit_code_ty <- mkTyConTy <$> tcLookupKnownOccTyCon exitCodeTyConOcc
|
|
2048
|
2045
|
main_res_ty <- liftZonkM $ zonkTcType res_ty
|
|
2049
|
|
-
|
|
2050
|
|
- let unit_valid = isJust (tcUnifyTy main_res_ty unitTy)
|
|
2051
|
|
- void_valid = isJust (tcUnifyTy main_res_ty void_ty)
|
|
2052
|
|
- exit_code_valid = isJust (tcUnifyTy main_res_ty exit_code_ty)
|
|
2053
|
|
-
|
|
2054
|
|
- setSrcSpan (getSrcSpan main_name) $
|
|
2055
|
|
- if meaningful_main
|
|
2056
|
|
- then checkTc
|
|
2057
|
|
- (unit_valid || void_valid || exit_code_valid)
|
|
2058
|
|
- (TcRnInvalidMainReturn main_name main_res_ty)
|
|
2059
|
|
- else diagnosticTc
|
|
2060
|
|
- (not (unit_valid || void_valid))
|
|
2061
|
|
- (TcRnAmbiguousMainReturn main_name main_res_ty)
|
|
2062
|
|
-
|
|
2063
|
|
- let main_action = mkHsDictLet ev_binds main_expr
|
|
2064
|
|
-
|
|
2065
|
|
- if not meaningful_main || unit_valid || void_valid
|
|
|
2046
|
+ if unifies main_res_ty unitTy
|
|
2066
|
2047
|
then pure main_action
|
|
2067
|
2048
|
else do
|
|
2068
|
|
- massertPpr exit_code_valid (ppr main_res_ty)
|
|
2069
|
|
- bind_io_id <- tcLookupKnownOccId bindIOIdOcc
|
|
2070
|
|
- exit_with_id <- tcLookupKnownOccId exitWithIdOcc
|
|
2071
|
|
- pure $
|
|
2072
|
|
- nlHsTyApps bind_io_id [exit_code_ty, exit_code_ty]
|
|
2073
|
|
- [ main_action, nlHsTyApp exit_with_id [exit_code_ty] ]
|
|
|
2049
|
+ void_ty <- mkTyConTy <$> tcLookupKnownOccTyCon voidTyConOcc
|
|
|
2050
|
+ if unifies main_res_ty void_ty
|
|
|
2051
|
+ then pure main_action
|
|
|
2052
|
+ else do
|
|
|
2053
|
+ meaningful_main <- xoptM LangExt.MeaningfulMainReturn
|
|
|
2054
|
+ if not meaningful_main
|
|
|
2055
|
+ then do
|
|
|
2056
|
+ setSrcSpan (getSrcSpan main_name) $
|
|
|
2057
|
+ addDiagnosticTc (TcRnAmbiguousMainReturn main_name main_res_ty)
|
|
|
2058
|
+ pure main_action
|
|
|
2059
|
+ else wrapExitWith main_res_ty
|
|
|
2060
|
+ where
|
|
|
2061
|
+ main_action = mkHsDictLet ev_binds main_expr
|
|
|
2062
|
+ unifies = (isJust .) . tcUnifyTy
|
|
|
2063
|
+ wrapExitWith main_res_ty = do
|
|
|
2064
|
+ exit_code_ty <- mkTyConTy <$> tcLookupKnownOccTyCon exitCodeTyConOcc
|
|
|
2065
|
+ setSrcSpan (getSrcSpan main_name) $
|
|
|
2066
|
+ checkTc (unifies main_res_ty exit_code_ty)
|
|
|
2067
|
+ (TcRnInvalidMainReturn main_name main_res_ty)
|
|
|
2068
|
+ bind_io_id <- tcLookupKnownOccId bindIOIdOcc
|
|
|
2069
|
+ exit_with_id <- tcLookupKnownOccId exitWithIdOcc
|
|
|
2070
|
+ pure $ nlHsTyApps bind_io_id [exit_code_ty, exit_code_ty]
|
|
|
2071
|
+ [ main_action, nlHsTyApp exit_with_id [exit_code_ty] ]
|
|
2074
|
2072
|
|
|
2075
|
2073
|
getIOType :: TcM (TcType, TcType)
|
|
2076
|
2074
|
-- Return (IO alpha, alpha) for fresh alpha
|