ghc/compiler/deSugar/MatchProc.lhs

   1 %               Filename:  %M%
   2 %               Version :  %I%
   3 %               Date    :  %G%
   4 %
   5 \section[MatchProcessors]{Pattern-matching processors}
   6 \begin{code}
   7 module MatchProc (
   8     matchProcessor
   9 ) where
  10
  11 #include "HsVersions.h"
  12
  13 import AbsSyn           -- the stuff being desugared
  14 import PlainCore        -- the output of desugaring;
  15                         -- importing this module also gets all the
  16                         -- CoreSyn utility functions
  17 import DsMonad          -- the monadery used in the desugarer
  18
  19 import AbsUniType       ( mkTyVarTy, splitType, mkProcessorTyCon,
  20                           TyVar, TyCon, Class, UniType,
  21                           TauType(..)
  22                         )
  23 import DsUtils          ( EquationInfo(..), selectMatchVars )
  24 import Id               ( getDataConFamily, getDataConTyCon,
  25                           getIdUniType, mkProcessorCon
  26                         )
  27 import ListSetOps       ( minusList )
  28 import Maybes           ( Maybe(..) )
  29 import Match            ( match )
  30 import Util
  31 import DsExpr           ( dsExpr)
  32 \end{code}
  33
  34 The matching of processors is based upon that of constructors. Given the
  35 pattern :
  36 \begin{verbatim}
  37         (|x1,..xn;y|)
  38 \end{verbatim}
  39
  40 The pattern matching compiler converts the above into :
  41 \begin{verbatim}
  42         case x of
  43                 (|u1,..un;uy|) -> let x1 = fromDomain u_1 of
  44                                          ....
  45                                   let xn = fromDomain u_n of
  46                                   let y  = fromDomain uy of
  47                                       PATTERN MATCH REST
  48 \end{verbatim}
  49
  50 \begin{code}
  51 matchProcessor :: [Id]
  52                -> [EquationInfo]
  53                -> PlainCoreExpr
  54                -> DsM PlainCoreExpr
  55
  56 matchProcessor (v:vs) eqnInfo ifFail
  57   = selectMatchVars [pat]                    `thenDs`   (\ [var]             ->
  58     selectMatchVars pats                     `thenDs`   (\ vars              ->
  59     match (var:vs)
  60           [(pat:ps,after_fun)]
  61           ifFail                             `thenDs`   (\ body              ->
  62     create_lets vars pats convs body ifFail  `thenDs`   (\ rhs               ->
  63     returnDs (
  64       CoCase
  65           (CoVar v)
  66           (CoAlgAlts
  67               [((mkProcessorCon podSize),vars++[var], rhs)]
  68               CoNoDefault))
  69     ))))
  70   where
  71     podSize = (length pats)
  72     -- Sanity checking pattern match. Product type of processors ensures
  73     -- there can be only one result if the equations are properly unmixed.
  74     ((ProcessorPat pats convs pat):ps,after_fun)
  75         | length eqnInfo == 1 = head eqnInfo
  76         | otherwise           = panic "matchProcessor more than one"
  77
  78 \end{code}
  79
  80 \begin{code}
  81 create_lets::[Id] ->
  82              [TypecheckedPat] ->
  83              [TypecheckedExpr] ->
  84              PlainCoreExpr ->
  85              PlainCoreExpr ->
  86              (DsM PlainCoreExpr)
  87
  88 create_lets [] _ _ body _ = returnDs (body)
  89 create_lets (v:vs) (p:ps) (c:cs) body ifFail
  90    = selectMatchVars [p]                        `thenDs`  (\ var   ->
  91      create_lets vs ps cs body ifFail           `thenDs`  (\ after ->
  92      dsExpr c                                   `thenDs`  (\ c'    ->
  93      match var
  94            [([p], \x -> after)]
  95            ifFail                               `thenDs`  (\ exp  ->
  96      returnDs ( CoApp (CoLam var exp) (CoApp c' (CoVar v))) ))))
  97 \end{code}
  98