[project @ 1997-05-19 00:12:10 by sof]
[ghc-hetmet.git] / ghc / compiler / reader / PrefixToHs.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 %
4 \section[PrefixToHS]{Support routines for converting ``prefix form'' to Haskell abstract syntax}
5
6 Support routines for reading prefix-form from the Lex/Yacc parser.
7
8 \begin{code}
9 #include "HsVersions.h"
10
11 module PrefixToHs (
12         cvValSig,
13         cvClassOpSig,
14         cvInstDeclSig,
15
16         cvBinds,
17         cvMonoBindsAndSigs,
18         cvMatches,
19         cvOtherDecls
20     ) where
21
22 IMP_Ubiq(){-uitous-}
23
24 import PrefixSyn        -- and various syntaxen.
25 import HsSyn
26 import RdrHsSyn
27 import HsPragmas        ( noGenPragmas, noClassOpPragmas )
28
29 import SrcLoc           ( mkSrcLoc )
30 import Util             ( mapAndUnzip, panic, assertPanic )
31 \end{code}
32
33 %************************************************************************
34 %*                                                                      *
35 \subsection[cvDecls]{Convert various top-level declarations}
36 %*                                                                      *
37 %************************************************************************
38
39 We make a point not to throw any user-pragma ``sigs'' at
40 these conversion functions:
41 \begin{code}
42 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
43
44 cvValSig (RdrTySig vars poly_ty src_loc)
45   = [ Sig v poly_ty src_loc | v <- vars ]
46
47 cvClassOpSig (RdrTySig vars poly_ty src_loc)
48   = [ ClassOpSig v v poly_ty src_loc | v <- vars ]
49
50 cvInstDeclSig (RdrSpecValSig        sigs) = sigs
51 cvInstDeclSig (RdrInlineValSig      sig)  = [ sig ]
52 cvInstDeclSig (RdrDeforestSig       sig)  = [ sig ]
53 cvInstDeclSig (RdrMagicUnfoldingSig sig)  = [ sig ]
54 \end{code}
55
56 %************************************************************************
57 %*                                                                      *
58 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
59 %*                                                                      *
60 %************************************************************************
61
62 Function definitions are restructured here. Each is assumed to be recursive
63 initially, and non recursive definitions are discovered by the dependency
64 analyser.
65
66 \begin{code}
67 cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds
68 cvBinds sf sig_cvtr binding
69   = case (cvMonoBindsAndSigs sf sig_cvtr binding) of { (mbs, sigs) ->
70     MonoBind mbs sigs recursive
71     }
72 \end{code}
73
74 \begin{code}
75 cvMonoBindsAndSigs :: SrcFile
76                    -> SigConverter
77                    -> RdrBinding
78                    -> (RdrNameMonoBinds, [RdrNameSig])
79
80 cvMonoBindsAndSigs sf sig_cvtr fb
81   = mangle_bind (EmptyMonoBinds, []) fb
82   where
83     -- If the function being bound has at least one argument, then the
84     -- guarded right hand sides of each pattern binding are knitted
85     -- into a series of patterns, each matched with its corresponding
86     -- guarded right hand side (which may contain several
87     -- alternatives). This series is then paired with the name of the
88     -- function. Otherwise there is only one pattern, which is paired
89     -- with a guarded right hand side.
90
91     mangle_bind acc (RdrAndBindings fb1 fb2)
92       = mangle_bind (mangle_bind acc fb1) fb2
93
94     mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _)
95       = (b_acc, s_acc ++ sig_cvtr sig)
96
97     mangle_bind (b_acc, s_acc) (RdrSpecValSig        sig) = (b_acc, sig ++ s_acc)
98     mangle_bind (b_acc, s_acc) (RdrInlineValSig      sig) = (b_acc, sig : s_acc)
99     mangle_bind (b_acc, s_acc) (RdrDeforestSig       sig) = (b_acc, sig : s_acc)
100     mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc)
101
102     mangle_bind (b_acc, s_acc)
103                 (RdrPatternBinding lousy_srcline [patbinding])
104       -- WDP: the parser has trouble getting a good line-number on RdrPatternBindings.
105       = case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) ->
106         let
107             src_loc = mkSrcLoc sf good_srcline
108         in
109         (b_acc `AndMonoBinds`
110          PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc)
111         }
112       where
113         good_srcline = case patbinding of
114                          RdrMatch_NoGuard ln _ _ _ _ -> ln
115                          RdrMatch_Guards  ln _ _ _ _ -> ln
116
117
118     mangle_bind _ (RdrPatternBinding _ _)
119       = panic "mangleBinding: more than one pattern on a RdrPatternBinding"
120
121     mangle_bind (b_acc, s_acc) (RdrFunctionBinding srcline patbindings)
122             -- must be a function binding...
123       = case (cvFunMonoBind sf patbindings) of { (var, inf, matches) ->
124         (b_acc `AndMonoBinds`
125          FunMonoBind var inf matches (mkSrcLoc sf srcline), s_acc)
126         }
127
128     mangle_bind (b_acc, s_acc) other = (b_acc, s_acc)
129 \end{code}
130
131 \begin{code}
132 cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds)
133
134 cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
135   = (pat, [OtherwiseGRHS expr (mkSrcLoc sf srcline)], cvBinds sf cvValSig binding)
136
137 cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding)
138   = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding)
139
140 cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, Bool {-InfixDefn-}, [RdrNameMatch])
141
142 cvFunMonoBind sf matches
143   = (head srcfuns, head infixdefs, cvMatches sf False matches)
144   where
145     (srcfuns, infixdefs) = mapAndUnzip get_mdef matches
146     -- ToDo: Check for consistent srcfun and infixdef
147
148     get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat
149     get_mdef (RdrMatch_Guards  _ sfun pat _ _) = get_pdef pat
150
151     get_pdef (ConPatIn fn _)       = (fn, False)
152     get_pdef (ConOpPatIn _ op _ _) = (op, True)
153     get_pdef (ParPatIn pat)        = get_pdef pat
154
155
156 cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch]
157 cvMatch   :: SrcFile -> Bool -> RdrMatch   -> RdrNameMatch
158
159 cvMatches sf is_case matches = map (cvMatch sf is_case) matches
160
161 cvMatch sf is_case rdr_match
162   = foldr PatMatch
163           (GRHSMatch (GRHSsAndBindsIn guarded_exprs (cvBinds sf cvValSig binding)))
164
165           -- For a FunMonoBinds, the first flattened "pattern" is
166           -- just the function name, and we don't want to keep it.
167           -- For a case expr, it's (presumably) a constructor name -- and
168           -- we most certainly want to keep it!  Hence the monkey busines...
169
170           (if is_case then -- just one pattern: leave it untouched...
171               [pat]
172            else            -- function pattern; extract arg patterns...
173               case pat of ConPatIn fn pats      -> pats
174                           ConOpPatIn p1 op _ p2 -> [p1,p2]
175                           ParPatIn pat          -> panic "PrefixToHs.cvMatch:ParPatIn"
176           )
177   where
178     (pat, binding, guarded_exprs)
179       = case rdr_match of
180           RdrMatch_NoGuard ln b c expr    d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc sf ln)])
181           RdrMatch_Guards  ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
182
183 cvGRHS :: SrcFile -> SrcLine -> ([RdrNameStmt], RdrNameHsExpr) -> RdrNameGRHS
184 cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc sf sl)
185 \end{code}
186
187 %************************************************************************
188 %*                                                                      *
189 \subsection[PrefixToHS-utils]{Utilities for conversion}
190 %*                                                                      *
191 %************************************************************************
192
193 Separate declarations into all the various kinds:
194
195 \begin{code}
196 cvOtherDecls :: RdrBinding -> [RdrNameHsDecl]
197 cvOtherDecls b 
198   = go [] b
199   where
200     go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
201     go acc (RdrTyDecl d)          = TyD d   : acc
202     go acc (RdrClassDecl d)       = ClD d   : acc
203     go acc (RdrInstDecl d)        = InstD d : acc 
204     go acc (RdrDefaultDecl d)     = DefD d  : acc
205     go acc other                  = acc
206 \end{code}