ghc/compiler/typecheck/TcMonoBnds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcMonoBinds]{TcMonoBinds}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcMonoBnds ( tcMonoBinds ) where
  10
  11 import TcMonad          -- typechecking monad machinery
  12 import AbsSyn           -- the stuff being typechecked
  13
  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
  19 import CE
  20 #endif
  21 import TCE
  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 )
  31 import Util
  32 \end{code}
  33
  34 \begin{code}
  35 tcMonoBinds :: E -> RenamedMonoBinds -> TcM (TypecheckedMonoBinds, LIE)
  36
  37 tcMonoBinds e EmptyMonoBinds = returnTc (EmptyMonoBinds, nullLIE)
  38
  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)
  43
  44 tcMonoBinds e (PatMonoBind pat grhss_and_binds locn)
  45          -- much like tcMatches of GRHSMatch
  46   = addSrcLocTc locn             (
  47
  48          -- LEFT HAND SIDE
  49     tcPat e pat         `thenTc` \ (pat2, lie_pat, pat_ty) ->
  50
  51          -- BINDINGS AND THEN GRHSS
  52     tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
  53
  54     unifyTauTy pat_ty grhss_ty (PatMonoBindsCtxt pat grhss_and_binds) `thenTc_`
  55
  56     (case pat of
  57       VarPatIn fun -> chk_main_or_mainIOish_type e fun pat_ty
  58       _            -> returnTc (panic "chk_main_or_mainIOish_type (pat)")
  59     )                                 `thenTc_`
  60
  61         -- Check for primitive types in the pattern (no can do)
  62 {- does not work here
  63     checkTc (any_con_w_prim_arg pat2)
  64             (error "Can't have primitive type in a pattern binding") `thenTc_`
  65 -}
  66
  67         -- RETURN
  68     returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
  69               plusLIE lie_pat lie)
  70     )
  71
  72 tcMonoBinds e (FunMonoBind name matches locn)
  73   = addSrcLocTc locn                    (
  74     let  id = lookupE_Binder e name  in
  75
  76     tcMatchesFun e name (getIdUniType id) matches   `thenTc` \ (matches', lie) ->
  77
  78     chk_main_or_mainIOish_type e name (getIdUniType id)  `thenTc_`
  79
  80     returnTc (FunMonoBind id matches' locn, lie)
  81     )
  82
  83 chk_main_or_mainIOish_type :: E -> Name -> UniType -> TcM ()
  84
  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
  89
  90 chk_main_or_mainIOish_type e name chk_ty
  91   = getSwitchCheckerTc  `thenNF_Tc` \ sw_chkr ->
  92     let
  93         tce         = getE_TCE e
  94         haskell_1_3 = sw_chkr Haskell_1_3
  95
  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)
 101 -}
 102         dialogue_tc = lookupTCE tce (PreludeTyCon dialogueTyConKey bottom 0 False)
 103         dialogue_ty = applySynTyCon dialogue_tc []
 104
 105         io_tc       = lookupTCE tce (PreludeTyCon iOTyConKey bottom 1 False)
 106         io_tup0_ty  = applySynTyCon io_tc [unitTy]
 107
 108         bottom      = panic "chk_main_or..."
 109     in
 110     if is_a_particular_thing SLIT("Main") SLIT("main") name then
 111         if haskell_1_3 then
 112             unifyTauTy io_tup0_ty  chk_ty (MatchCtxt io_tup0_ty  chk_ty)
 113         else
 114             unifyTauTy dialogue_ty chk_ty (MatchCtxt dialogue_ty chk_ty)
 115
 116     else if is_a_particular_thing SLIT("Main") SLIT("mainPrimIO") name then
 117        let
 118             ioprim_ty = mkPrimIoTy unitTy
 119        in
 120        unifyTauTy ioprim_ty chk_ty (MatchCtxt ioprim_ty chk_ty)
 121     else
 122        returnTc bottom
 123   where
 124     is_a_particular_thing :: FAST_STRING -> FAST_STRING -> Name -> Bool
 125
 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
 130 \end{code}