ghc/compiler/deSugar/DsParZF.lhs

   1 %************************************************************************
   2 %*                                                                      *
   3 \section[DsParZF]{Desugaring Parallel ZF expressisions}
   4 %*                                                                      *
   5 %************************************************************************
   6
   7 \begin{code}
   8 #include "HsVersions.h"
   9 module DsParZF  where
  10
  11 IMPORT_Trace            -- ToDo: rm
  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 import AbsPrel          ( mkFunTy , eRROR_ID , integerTy,
  19                           fromDomainId , toDomainId)
  20 import DsExpr           ( dsExpr )
  21 import DsUtils          ( mkSelectorBinds , EquationInfo(..))
  22 import Match            ( match )
  23 import FiniteMap        -- WAS: Set
  24 import FreeVars
  25 import SrcLoc
  26 import BasicLit          ( BasicLit(..) )
  27 import Util
  28 \end{code}
  29
  30 The purpose of the module is to convert the abstract syntax representation
  31 of parallel ZF expressions into the core syntax representation. The two
  32 representations differ in that the core syntax only contains binders in
  33 drawn and index from generators.
  34
  35 \begin{description}
  36 \item[The ``Idea''] For each pattern in a generator we apply the function
  37 $\lambda hole\ .\ {\cal D}[[{\tt (\\pat ->}\ hole {\tt )x}]]$ to
  38 {\em every} expression in an inner scope than that of the definition of
  39 the pattern; {\tt x} represents the binder in the generator after translation,
  40 ${\cal D}[[exp]]$ represents the desugaring of the expression $exp$.
  41
  42 \item[Optimising the ``Idea''] We catagorise each pattern into two types;
  43 simple patterns in which their are no binders, and complex patterns. We
  44 only apply simple patterns to the left handside of a ZF expressions, and
  45 complex patterns to expressions in which the intersection of the free
  46 variables of the expression, and the binders of the pattern is non-empty.
  47 \end{description}
  48
  49 %************************************************************************
  50 %*                                                                      *
  51 \subsection[dsParallelZF]{Interface to the outside world}
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 \begin{code}
  56 dsParallelZF::TypecheckedExpr -> TypecheckedParQuals -> DsM PlainCoreExpr
  57 dsParallelZF expr quals
  58   = dsParQuals quals                    `thenDs`        (\ (quals',hf)   ->
  59     dsExpr expr                         `thenDs`        ( \ expr'        ->
  60     let_1_0 (typeOfCoreExpr expr')                      ( \ ty           ->
  61     returnDs (CoZfExpr (applyHoleLhsExpr ty expr' hf) quals') )))
  62 \end{code}
  63
  64 %************************************************************************
  65 %*                                                                      *
  66 \subsection[dsZF_datatype]{DataType used to represent ``HoleFunction''}
  67 %*                                                                      *
  68 %************************************************************************
  69
  70 \begin{code}
  71 type HoleFunction = (UniType -> PlainCoreExpr -> PlainCoreExpr,
  72                      [(PlainCoreExpr -> Bool,
  73                        UniType -> PlainCoreExpr -> PlainCoreExpr)])
  74 \end{code}
  75
  76 \begin{code}
  77 combine fn fn' = \t e -> fn t (fn' t e)
  78 \end{code}
  79
  80 \begin{code}
  81 combineHoles:: HoleFunction -> HoleFunction -> HoleFunction
  82 combineHoles (lhs,rhs) (lhs',rhs')
  83    = (combine lhs lhs',rhs++rhs')
  84 \end{code}
  85
  86 \begin{code}
  87 identityHole::HoleFunction
  88 identityHole = (\t e -> e,[])
  89 \end{code}
  90
  91 \begin{code}
  92 applyHoleLhsExpr:: UniType
  93                 -> PlainCoreExpr
  94                 -> HoleFunction
  95                 -> PlainCoreExpr
  96 applyHoleLhsExpr ty expr (lhs,rhs)
  97    = (combine lhs (foldr combine (\t e -> e) (map snd rhs))) ty expr
  98 \end{code}
  99
 100 \begin{code}
 101 applyHoleRhsExpr ty expr (_,rhs)
 102    = (foldr combine (\t e -> e) [ y | (x,y) <- rhs, (x expr)]) ty expr
 103 \end{code}
 104
 105 \begin{code}
 106 applyHoleFunction :: PlainCoreParQuals
 107                   -> HoleFunction
 108                   -> PlainCoreParQuals
 109 applyHoleFunction (CoAndQuals left right) hf
 110    = CoAndQuals (applyHoleFunction left hf) (applyHoleFunction right hf)
 111
 112 applyHoleFunction (CoParFilter expr) hf
 113    = CoParFilter (applyHoleRhsExpr (typeOfCoreExpr expr) expr hf)
 114
 115 applyHoleFunction (CoDrawnGen pats pat expr) hf
 116    = CoDrawnGen pats pat (applyHoleRhsExpr (typeOfCoreExpr expr) expr hf)
 117
 118 applyHoleFunction (CoIndexGen exprs pat expr) hf
 119    = CoIndexGen (map (\x -> applyHoleRhsExpr (typeOfCoreExpr x) x hf) exprs)
 120                 pat
 121                 (applyHoleRhsExpr (typeOfCoreExpr expr) expr hf)
 122 \end{code}
 123
 124 %************************************************************************
 125 %*                                                                      *
 126 \subsection[dsParQuals]{Desugaring the qualifiers}
 127 %*                                                                      *
 128 %************************************************************************
 129
 130 \begin{code}
 131 dsParQuals::TypecheckedParQuals
 132            -> DsM (PlainCoreParQuals,HoleFunction)
 133 \end{code}
 134
 135 \begin{code}
 136 dsParQuals (AndParQuals left right)
 137    = dsParQuals left            `thenDs`      (\ (left', hfleft)  ->
 138      dsParQuals right           `thenDs`      (\ (right',hfright) ->
 139      returnDs (CoAndQuals left'  (applyHoleFunction right' hfleft),
 140                combineHoles hfleft hfright) ))
 141
 142 \end{code}
 143
 144 \begin{code}
 145 dsParQuals (ParFilter expr)
 146    = dsExpr expr                `thenDs`        (\ expr' ->
 147      returnDs (CoParFilter expr', identityHole) )
 148
 149 dsParQuals (DrawnGenOut pats convs pat dRHS)
 150    = listDs  (map dsExpr convs) `thenDs`        (\ convs'          ->
 151      listDs  (map prettyNewLocalDs pats)
 152                                 `thenDs`        (\ binders         ->
 153      listDs (zipWith3 dsPid  pats binders convs')
 154                                 `thenDs`        (\ hfList          ->
 155      let_1_0 (foldr1 (combineHoles) hfList)     (\ hf              ->
 156      prettyNewLocalDs pat       `thenDs`        (\ iden            ->
 157      duplicateLocalDs iden      `thenDs`        (\ binder          ->
 158      dsPid pat binder (CoLam [iden] (CoVar iden))
 159                                 `thenDs`        (\ hf'             ->
 160      dsExpr dRHS                `thenDs`        (\ dRHS'           ->
 161      returnDs (CoDrawnGen binders binder dRHS',
 162                combineHoles hf hf') ))))))))
 163
 164
 165 dsParQuals (IndexGen exprs pat iRHS)
 166    = listDs (map dsExpr exprs)  `thenDs`        (\ exprs'        ->
 167      prettyNewLocalDs pat       `thenDs`        (\ binder          ->
 168      duplicateLocalDs binder    `thenDs`        (\ iden        ->
 169      dsPid pat binder (CoLam [iden] (CoVar iden))
 170                                 `thenDs`        (\ hf            ->
 171      dsExpr iRHS                `thenDs`        (\ iRHS'         ->
 172      returnDs (CoIndexGen exprs' binder iRHS' ,hf) )))))
 173
 174 \end{code}
 175
 176 \begin{code}
 177 dsPid:: TypecheckedPat                  -- Pattern to be desugared
 178      -> Id                              -- Patterns desugared binder
 179      -> PlainCoreExpr                   -- Conversion function
 180      -> DsM HoleFunction
 181
 182 dsPid pat binder conv
 183   = duplicateLocalDs binder     `thenDs`                (\ lambdaBind    ->
 184     getSrcLocDs                 `thenDs`                (\ (sfile,sline) ->
 185     let_1_0 ("\""++sfile++"\", line "++sline++" : "++
 186              "Processor not defined\n")                 ( \ errorStr     ->
 187     getUniqueSupplyDs           `thenDs`                (\ us            ->
 188     let_1_0 (collectTypedPatBinders pat)                (\ patBinders    ->
 189     case (null patBinders) of
 190     True  -> returnDs (mkHole lambdaBind errorStr us,[])
 191     False ->
 192        returnDs (\t e -> e, [(mkPredicate patBinders,
 193                               mkHole lambdaBind errorStr us)]) )))))
 194
 195   where
 196      mkPredicate b e
 197         = let_1_0 (freeStuff b e)       (\ ((fvSet,_),_) ->
 198           let_1_0 (mkSet b)             (\ bSet          ->
 199           not (isEmptySet (intersect fvSet bSet)) ))
 200
 201      mkHole lambdaBind errorStr us
 202         = \ ty expr ->
 203              (CoApp
 204                 (CoLam
 205                    [lambdaBind]
 206                    (snd (initDs
 207                            us
 208                            nullIdEnv
 209                            (\ _ -> False)       -- Hack alert!!!
 210                            (panic "mkHole: module name")
 211                            (match [lambdaBind] [([pat], \x -> expr)]
 212                                   (CoApp
 213                                      (mkCoTyApp (CoVar eRROR_ID) ty)
 214                                      (CoLit (NoRepStr (_PK_ errorStr))))))))
 215                 (CoApp conv (CoVar binder)))
 216 \end{code}
 217
 218 In the mkHole function we need to conjure up some state so we can
 219 use the match function...
 220 %************************************************************************
 221 %*                                                                      *
 222 \subsection[prettyLocals]{Make a new binder; try and keep names nice :-)}
 223 %*                                                                      *
 224 %************************************************************************
 225
 226 \begin{code}
 227 prettyNewLocalDs::TypecheckedPat -> DsM Id
 228 prettyNewLocalDs (VarPat id)  = duplicateLocalDs id
 229 prettyNewLocalDs (AsPat id _) = duplicateLocalDs id
 230 preetyNewLocalDs pat          = let_1_0 (typeOfPat pat)         (\ pat_ty->
 231                                 newSysLocalDs pat_ty
 232                                 )
 233 \end{code}