[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / 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}