2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[PrefixToHS]{Support routines for converting ``prefix form'' to Haskell abstract syntax}
6 Support routines for reading prefix-form from the Lex/Yacc parser.
9 #include "HsVersions.h"
22 sepDeclsIntoSigsAndBinds
25 IMPORT_Trace -- ToDo: rm
29 import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
30 import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
33 import ProtoName -- ProtoName(..), etc.
34 import SrcLoc ( mkSrcLoc2 )
38 %************************************************************************
40 \subsection[cvDecls]{Convert various top-level declarations}
42 %************************************************************************
45 cvInstDecls :: Bool -> FAST_STRING -> FAST_STRING
46 -> [FAST_STRING -> FAST_STRING -> Bool -> ProtoNameInstDecl] -- incomplete InstDecls
47 -> [ProtoNameInstDecl]
49 cvInstDecls from_here orig_modname informant_modname decls
50 = [ decl_almost orig_modname informant_modname from_here
51 | decl_almost <- decls ]
54 We make a point not to throw any user-pragma ``sigs'' at
55 these conversion functions:
57 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
59 cvValSig (RdrTySig vars poly_ty pragmas src_loc)
60 = [ Sig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ]
62 cvt_pragmas RdrNoPragma = NoGenPragmas
63 cvt_pragmas (RdrGenPragmas ps) = ps
65 cvClassOpSig (RdrTySig vars poly_ty pragmas src_loc)
66 = [ ClassOpSig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ]
68 cvt_pragmas RdrNoPragma = NoClassOpPragmas
69 cvt_pragmas (RdrClassOpPragmas ps) = ps
71 cvInstDeclSig (RdrSpecValSig sigs) = sigs
72 cvInstDeclSig (RdrInlineValSig sig) = [ sig ]
73 cvInstDeclSig (RdrDeforestSig sig) = [ sig ]
74 cvInstDeclSig (RdrMagicUnfoldingSig sig) = [ sig ]
77 %************************************************************************
79 \subsection[cvBinds-etc]{Converting to @Binds@, @MonoBinds@, etc.}
81 %************************************************************************
83 Function definitions are restructured here. Each is assumed to be recursive
84 initially, and non recursive definitions are discovered by the dependency
88 cvBinds :: SrcFile -> SigConverter -> RdrBinding -> ProtoNameBinds
89 cvBinds sf sig_cvtr raw_binding
90 = cvSepdBinds sf sig_cvtr (sepDeclsForBinds raw_binding)
92 cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> ProtoNameBinds
93 cvSepdBinds sf sig_cvtr bindings
94 = case (mkMonoBindsAndSigs sf sig_cvtr bindings) of { (mbs, sigs) ->
96 then SingleBind (RecBind mbs)
97 else BindWith (RecBind mbs) sigs
100 cvMonoBinds :: SrcFile -> [RdrBinding] -> ProtoNameMonoBinds
101 cvMonoBinds sf bindings
102 = case (mkMonoBindsAndSigs sf bottom bindings) of { (mbs,sigs) ->
105 else panic "cvMonoBinds: some sigs present"
108 bottom = panic "cvMonoBinds: sig converter!"
112 mkMonoBindsAndSigs :: SrcFile
115 -> (ProtoNameMonoBinds, [ProtoNameSig])
117 mkMonoBindsAndSigs sf sig_cvtr fbs
118 = foldl mangle_bind (EmptyMonoBinds, []) fbs
120 -- If the function being bound has at least one argument, then the
121 -- guarded right hand sides of each pattern binding are knitted
122 -- into a series of patterns, each matched with its corresponding
123 -- guarded right hand side (which may contain several
124 -- alternatives). This series is then paired with the name of the
125 -- function. Otherwise there is only one pattern, which is paired
126 -- with a guarded right hand side.
128 mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _ _)
129 = (b_acc, s_acc ++ sig_cvtr sig)
131 mangle_bind (b_acc, s_acc) (RdrSpecValSig sig) = (b_acc, sig ++ s_acc)
132 mangle_bind (b_acc, s_acc) (RdrInlineValSig sig) = (b_acc, sig : s_acc)
133 mangle_bind (b_acc, s_acc) (RdrDeforestSig sig) = (b_acc, sig : s_acc)
134 mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc)
136 mangle_bind (b_acc, s_acc)
137 (RdrPatternBinding lousy_srcline [patbinding@(RdrMatch good_srcline _ _ _ _)])
138 -- WDP: the parser has trouble getting a good line-number on RdrPatternBindings.
139 = case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) ->
141 src_loc = mkSrcLoc2 sf good_srcline
143 (b_acc `AndMonoBinds`
144 PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc)
147 mangle_bind _ (RdrPatternBinding _ _)
148 = panic "mangleBinding: more than one pattern on a RdrPatternBinding"
150 mangle_bind (b_acc, s_acc) (RdrFunctionBinding srcline patbindings)
151 -- must be a function binding...
152 = case (cvFunMonoBind sf patbindings) of { (var, matches) ->
153 (b_acc `AndMonoBinds`
154 FunMonoBind var matches (mkSrcLoc2 sf srcline), s_acc)
159 cvPatMonoBind :: SrcFile -> RdrMatch -> (ProtoNamePat, [ProtoNameGRHS], ProtoNameBinds)
161 cvPatMonoBind sf (RdrMatch srcline srcfun pat guardedexprs binding)
162 = (pat, cvGRHSs srcfun sf srcline guardedexprs, cvBinds sf cvValSig binding)
164 cvFunMonoBind :: SrcFile -> [RdrMatch] -> (ProtoName {-VarName-}, [ProtoNameMatch])
166 cvFunMonoBind sf matches@((RdrMatch srcline srcfun pat guardedexprs binding):_)
167 = ( Unk srcfun, -- cheating ...
168 cvMatches sf False matches )
170 cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [ProtoNameMatch]
171 cvMatch :: SrcFile -> Bool -> RdrMatch -> ProtoNameMatch
173 cvMatches sf is_case matches = map (cvMatch sf is_case) matches
175 cvMatch sf is_case (RdrMatch srcline srcfun pat guardedexprs binding)
177 (GRHSMatch (GRHSsAndBindsIn (cvGRHSs srcfun sf srcline guardedexprs)
178 (cvBinds sf cvValSig binding)))
180 -- For a FunMonoBinds, the first flattened "pattern" is
181 -- just the function name, and we don't want to keep it.
182 -- For a case expr, it's (presumably) a constructor name -- and
183 -- we most certainly want to keep it! Hence the monkey busines...
185 -- (trace ("cvMatch:"++(ppShow 80 (ppr PprDebug pat))) (
186 (if is_case then -- just one pattern: leave it untouched...
190 ConPatIn _ pats -> pats
194 pat' = doctor_pat pat
196 -- a ConOpPatIn in the corner may be handled by converting it to
199 doctor_pat (ConOpPatIn p1 op p2) = ConPatIn op [p1, p2]
200 doctor_pat other_pat = other_pat
202 cvGRHSs :: FAST_STRING -> SrcFile -> SrcLine -> [(ProtoNameExpr, ProtoNameExpr)] -> [ProtoNameGRHS]
204 cvGRHSs sfun sf sl guarded_exprs = map (cvGRHS sfun sf sl) guarded_exprs
206 cvGRHS :: FAST_STRING -> SrcFile -> SrcLine -> (ProtoNameExpr, ProtoNameExpr) -> ProtoNameGRHS
208 cvGRHS sfun sf sl (Var v@(Unk str), e)
209 | str == SLIT("__o") -- "__otherwise" ToDo: de-urgh-ify
210 = OtherwiseGRHS e (mkSrcLoc2 sf sl)
212 cvGRHS sfun sf sl (g, e)
213 = GRHS g e (mkSrcLoc2 sf sl)
216 %************************************************************************
218 \subsection[PrefixToHS-utils]{Utilities for conversion}
220 %************************************************************************
222 Separate declarations into all the various kinds:
224 tys RdrTyData RdrTySynonym
225 type "sigs" RdrAbstractTypeSig RdrSpecDataSig
227 instances RdrInstDecl
228 instance "sigs" RdrSpecInstSig
229 defaults RdrDefaultDecl
230 binds RdrFunctionBinding RdrPatternBinding RdrTySig
231 RdrSpecValSig RdrInlineValSig RdrDeforestSig
233 iimps RdrIfaceImportDecl (interfaces only)
236 This function isn't called directly; some other function calls it,
237 then checks that what it got is appropriate for that situation.
238 (Those functions follow...)
241 sepDecls (RdrTyData a)
242 tys tysigs classes insts instsigs defaults binds iimps
243 = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps)
245 sepDecls (RdrTySynonym a)
246 tys tysigs classes insts instsigs defaults binds iimps
247 = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps)
249 sepDecls a@(RdrFunctionBinding _ _)
250 tys tysigs classes insts instsigs defaults binds iimps
251 = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
253 sepDecls a@(RdrPatternBinding _ _)
254 tys tysigs classes insts instsigs defaults binds iimps
255 = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
257 -- RdrAndBindings catered for below...
259 sepDecls (RdrClassDecl a)
260 tys tysigs classes insts instsigs defaults binds iimps
261 = (tys,tysigs,a:classes,insts,instsigs,defaults,binds,iimps)
263 sepDecls (RdrInstDecl a)
264 tys tysigs classes insts instsigs defaults binds iimps
265 = (tys,tysigs,classes,a:insts,instsigs,defaults,binds,iimps)
267 sepDecls (RdrDefaultDecl a)
268 tys tysigs classes insts instsigs defaults binds iimps
269 = (tys,tysigs,classes,insts,instsigs,a:defaults,binds,iimps)
271 sepDecls a@(RdrTySig _ _ _ _)
272 tys tysigs classes insts instsigs defaults binds iimps
273 = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
275 sepDecls (RdrIfaceImportDecl a)
276 tys tysigs classes insts instsigs defaults binds iimps
277 = (tys,tysigs,classes,insts,instsigs,defaults,binds,a:iimps)
279 sepDecls a@(RdrSpecValSig _)
280 tys tysigs classes insts instsigs defaults binds iimps
281 = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
283 sepDecls a@(RdrInlineValSig _)
284 tys tysigs classes insts instsigs defaults binds iimps
285 = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
287 sepDecls a@(RdrDeforestSig _)
288 tys tysigs classes insts instsigs defaults binds iimps
289 = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
291 sepDecls a@(RdrMagicUnfoldingSig _)
292 tys tysigs classes insts instsigs defaults binds iimps
293 = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
295 sepDecls (RdrSpecInstSig a)
296 tys tysigs classes insts instsigs defaults binds iimps
297 = (tys,tysigs,classes,insts,a:instsigs,defaults,binds,iimps)
299 sepDecls (RdrAbstractTypeSig a)
300 tys tysigs classes insts instsigs defaults binds iimps
301 = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps)
303 sepDecls (RdrSpecDataSig a)
304 tys tysigs classes insts instsigs defaults binds iimps
305 = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps)
308 tys tysigs classes insts instsigs defaults binds iimps
309 = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps)
311 sepDecls (RdrAndBindings bs1 bs2)
312 tys tysigs classes insts instsigs defaults binds iimps
313 = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds iimps) of {
314 (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) ->
315 sepDecls bs1 tys tysigs classes insts instsigs defaults binds iimps
320 sepDeclsForTopBinds binding
321 = case (sepDecls binding [] [] [] [] [] [] [] [])
322 of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) ->
324 (tys,tysigs,classes,insts,instsigs,defaults,binds)
327 sepDeclsForBinds binding
328 = case (sepDecls binding [] [] [] [] [] [] [] [])
329 of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) ->
340 sepDeclsIntoSigsAndBinds binding
341 = case (sepDeclsForBinds binding) of { sigs_and_binds ->
342 foldr sep_stuff ([],[]) sigs_and_binds
345 sep_stuff s@(RdrTySig _ _ _ _) (sigs,defs) = (s:sigs,defs)
346 sep_stuff s@(RdrSpecValSig _) (sigs,defs) = (s:sigs,defs)
347 sep_stuff s@(RdrInlineValSig _) (sigs,defs) = (s:sigs,defs)
348 sep_stuff s@(RdrDeforestSig _) (sigs,defs) = (s:sigs,defs)
349 sep_stuff s@(RdrMagicUnfoldingSig _) (sigs,defs) = (s:sigs,defs)
350 sep_stuff d@(RdrFunctionBinding _ _) (sigs,defs) = (sigs,d:defs)
351 sep_stuff d@(RdrPatternBinding _ _) (sigs,defs) = (sigs,d:defs)
354 sepDeclsForInterface binding
355 = case (sepDecls binding [] [] [] [] [] [] [] [])
356 of { (tys,tysigs,classes,insts,instsigs,defaults,sigs,iimps) ->
357 ASSERT ((null defaults)
360 ASSERT (not (not_all_sigs sigs))
361 (tys,classes,insts,sigs,iimps)
364 not_all_sigs sigs = not (all is_a_sig sigs)
366 is_a_sig (RdrTySig _ _ _ _) = True
367 is_a_sig anything_else = False