2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcMonoBinds]{TcMonoBinds}
7 #include "HsVersions.h"
9 module TcMonoBnds ( tcMonoBinds ) where
11 import TcMonad -- typechecking monad machinery
12 import AbsSyn -- the stuff being typechecked
14 import AbsPrel ( mkPrimIoTy, unitTy, mkListTy, mkFunTy )
15 import AbsUniType ( applyNonSynTyCon, applySynTyCon )
16 import CmdLineOpts ( GlobalSwitch(..) )
17 import E ( growE_LVE, lookupE_Binder, getE_TCE, E, GVE(..), LVE(..) )
18 #if USE_ATTACK_PRAGMAS
22 import Errors ( UnifyErrContext(..) ) -- notably PatMonoBindsCtxt
23 import Id ( getIdUniType, Id )
24 import LIE ( nullLIE, plusLIE, LIE )
25 import NameTypes ( FullName )
26 import TcGRHSs ( tcGRHSsAndBinds )
27 import TcMatches ( tcMatchesFun )
28 import TcPat ( tcPat )
29 import Unify ( unifyTauTy )
30 import Unique ( dialogueTyConKey, iOTyConKey )
35 tcMonoBinds :: E -> RenamedMonoBinds -> TcM (TypecheckedMonoBinds, LIE)
37 tcMonoBinds e EmptyMonoBinds = returnTc (EmptyMonoBinds, nullLIE)
39 tcMonoBinds e (AndMonoBinds mb1 mb2)
40 = tcMonoBinds e mb1 `thenTc` \ (mb1a, lie1) ->
41 tcMonoBinds e mb2 `thenTc` \ (mb2a, lie2) ->
42 returnTc (AndMonoBinds mb1a mb2a, plusLIE lie1 lie2)
44 tcMonoBinds e (PatMonoBind pat grhss_and_binds locn)
45 -- much like tcMatches of GRHSMatch
49 tcPat e pat `thenTc` \ (pat2, lie_pat, pat_ty) ->
51 -- BINDINGS AND THEN GRHSS
52 tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
54 unifyTauTy pat_ty grhss_ty (PatMonoBindsCtxt pat grhss_and_binds) `thenTc_`
57 VarPatIn fun -> chk_main_or_mainIOish_type e fun pat_ty
58 _ -> returnTc (panic "chk_main_or_mainIOish_type (pat)")
61 -- Check for primitive types in the pattern (no can do)
63 checkTc (any_con_w_prim_arg pat2)
64 (error "Can't have primitive type in a pattern binding") `thenTc_`
68 returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
72 tcMonoBinds e (FunMonoBind name matches locn)
74 let id = lookupE_Binder e name in
76 tcMatchesFun e name (getIdUniType id) matches `thenTc` \ (matches', lie) ->
78 chk_main_or_mainIOish_type e name (getIdUniType id) `thenTc_`
80 returnTc (FunMonoBind id matches' locn, lie)
83 chk_main_or_mainIOish_type :: E -> Name -> UniType -> TcM ()
85 -- profoundly ugly checking that ...
86 -- Main.main :: Dialogue -- Haskell 1.2
87 -- Main.main :: IO () -- Haskell 1.3
88 -- Main.mainPrimIO :: PrimIO () -- Glasgow extension
90 chk_main_or_mainIOish_type e name chk_ty
91 = getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
94 haskell_1_3 = sw_chkr Haskell_1_3
96 {-OLD: response_tc = lookupTCE tce (PreludeTyCon responseTyConKey bottom 0 True)
97 request_tc = lookupTCE tce (PreludeTyCon requestTyConKey bottom 0 True)
98 response_ty = applyNonSynTyCon response_tc []
99 request_ty = applyNonSynTyCon request_tc []
100 dialogue_ty = (mkListTy response_ty) `mkFunTy` (mkListTy request_ty)
102 dialogue_tc = lookupTCE tce (PreludeTyCon dialogueTyConKey bottom 0 False)
103 dialogue_ty = applySynTyCon dialogue_tc []
105 io_tc = lookupTCE tce (PreludeTyCon iOTyConKey bottom 1 False)
106 io_tup0_ty = applySynTyCon io_tc [unitTy]
108 bottom = panic "chk_main_or..."
110 if is_a_particular_thing SLIT("Main") SLIT("main") name then
112 unifyTauTy io_tup0_ty chk_ty (MatchCtxt io_tup0_ty chk_ty)
114 unifyTauTy dialogue_ty chk_ty (MatchCtxt dialogue_ty chk_ty)
116 else if is_a_particular_thing SLIT("Main") SLIT("mainPrimIO") name then
118 ioprim_ty = mkPrimIoTy unitTy
120 unifyTauTy ioprim_ty chk_ty (MatchCtxt ioprim_ty chk_ty)
124 is_a_particular_thing :: FAST_STRING -> FAST_STRING -> Name -> Bool
126 is_a_particular_thing mod_wanted nm_wanted (OtherTopId _ full_name)
127 = let (mod, nm) = getOrigName full_name
128 in mod == mod_wanted && nm == nm_wanted
129 is_a_particular_thing _ _ _ = False