ghc/compiler/typecheck/TcParQuals.lhs

   1 %               Filename:  %M%
   2 %               Version :  %I%
   3 %               Date    :  %G%
   4 %
   5 \section[TcParQuals]{TcParQuals}
   6
   7 \begin{code}
   8 module TcParQuals ( tcParQuals , tcPidPats , tcPidExprs ) where
   9
  10 #include "HsVersions.h"
  11
  12 import TcMonad          -- typechecking monad machinery
  13 import TcMonadFns
  14 import AbsSyn           -- the stuff being typechecked
  15
  16 import AbsPrel          ( boolTy, mkProcessorTy, mkPodTy ,
  17                           toDomainId, fromDomainId
  18                         )
  19 import AbsUniType
  20 import Id               ( mkInstId )
  21 import Inst             ( InstOrigin(..) )
  22 import E
  23 import LIE
  24 import TcExpr           ( tcExpr , tcExprs )
  25 import TcPat            ( tcPat , tcPats )
  26 import Unify
  27 import Util
  28 \end{code}
  29
  30
  31 \begin{code}
  32 tcParQuals :: E -> RenamedParQuals -> TcM (TypecheckedParQuals,LIE)
  33 tcParQuals e (AndParQuals quals1 quals2)
  34  = (tcParQuals e quals1)                   `thenTc` (\ (quals1',lie1) ->
  35    (tcParQuals e quals2)                   `thenTc` (\ (quals2',lie2) ->
  36    returnTc (AndParQuals quals1' quals2', lie1 `plusLIE` lie2) ))
  37
  38 tcParQuals e (ParFilter expr)
  39  = (tcExpr e expr)                              `thenTc`  (\ (expr',lie,ty) ->
  40    (unifyTauTy ty boolTy (ParFilterCtxt expr))  `thenTc_`
  41    returnTc (ParFilter expr',lie) )
  42
  43 tcParQuals e (DrawnGenIn pats pat expr)
  44  = (tcPidPats e pats)               `thenTc` (\ (pats',convs,lie1,patsTy) ->
  45    (tcPat     e pat)                `thenTc` (\ (pat' ,patTy, lie2) ->
  46    (tcExpr e expr)                  `thenTc` (\ (expr',lie3,exprTy) ->
  47    (unifyTauTy exprTy
  48                (mkPodTy (mkProcessorTy patsTy patTy))
  49                (DrawnCtxt pats pat expr))       `thenTc_`
  50    returnTc (DrawnGenOut pats' convs pat' expr',
  51             plusLIE (plusLIE lie1 lie2) lie3 ) )))
  52
  53 tcParQuals e (IndexGen exprs pat expr)
  54  = (tcPidExprs e exprs)                 `thenTc` (\ (exprs',lie1,exprsTy) ->
  55    (tcPat      e pat)                   `thenTc` (\ (pat',patTy,  lie2) ->
  56    (tcExpr e expr)                      `thenTc` (\ (expr',lie3,exprTy) ->
  57    (unifyTauTy exprTy
  58                (mkPodTy (mkProcessorTy exprsTy patTy))
  59                (IndexCtxt exprs pat expr))      `thenTc_`
  60    returnTc (IndexGen exprs' pat' expr',
  61              plusLIE (plusLIE lie1 lie2) lie3) )))
  62
  63 \end{code}
  64
  65 \begin{code}
  66 tcPidExprs:: E -> [RenamedExpr] -> TcM ([TypecheckedExpr],LIE,[TauType])
  67 tcPidExprs e exprs
  68   = tcExprs e exprs                          `thenTc`     (\ (exprs',lie,tys)->
  69     getSrcLocTc                              `thenNF_Tc`  (\ loc             ->
  70     listNF_Tc (map (getFromDomain loc) tys)  `thenNF_Tc`  (\ fromDomains     ->
  71     returnTc (zipWith mkConversion fromDomains exprs',
  72               mkLIE fromDomains `plusLIE` lie,tys)
  73     )))
  74   where
  75     getFromDomain loc ty
  76       = newMethod (OccurrenceOf toDomainId loc) fromDomainId [ty]
  77
  78     mkConversion fromDom expr
  79       = App (Var (mkInstId fromDom)) expr
  80 \end{code}
  81
  82 \begin{code}
  83 tcPidPats ::E ->[RenamedPat]->TcM ([TypecheckedPat],   -- Expression
  84                                    [TypecheckedExpr],  -- Conversion fns
  85                                    LIE,
  86                                    [UniType])
  87 tcPidPats e pats
  88   = tcPats e pats                          `thenTc`       (\ (pats',tys,lie)->
  89     getSrcLocTc                            `thenNF_Tc`    (\ loc            ->
  90     listNF_Tc (map (getToDomain loc) tys)  `thenNF_Tc`    (\ toDomains      ->
  91     returnTc (pats',map mkConversion toDomains,
  92               mkLIE toDomains `plusLIE` lie,tys)
  93     )))
  94   where
  95     getToDomain loc ty= newMethod (OccurrenceOf toDomainId loc) toDomainId [ty]
  96     mkConversion toDom= Var (mkInstId toDom)
  97 \end{code}