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         cvBinds,
  16         cvMatches,
  17         cvMonoBinds,
  18         cvSepdBinds,
  19         sepDeclsForTopBinds,
  20         sepDeclsIntoSigsAndBinds
  21     ) where
  22
  23 import Ubiq{-uitous-}
  24
  25 import PrefixSyn        -- and various syntaxen.
  26 import HsSyn
  27 import RdrHsSyn
  28 import HsPragmas        ( noGenPragmas, noClassOpPragmas )
  29
  30 import SrcLoc           ( mkSrcLoc2 )
  31 import Util             ( panic, assertPanic )
  32 \end{code}
  33
  34 %************************************************************************
  35 %*                                                                      *
  36 \subsection[cvDecls]{Convert various top-level declarations}
  37 %*                                                                      *
  38 %************************************************************************
  39
  40 We make a point not to throw any user-pragma ``sigs'' at
  41 these conversion functions:
  42 \begin{code}
  43 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
  44
  45 cvValSig (RdrTySig vars poly_ty src_loc)
  46   = [ Sig v poly_ty noGenPragmas src_loc | v <- vars ]
  47
  48 cvClassOpSig (RdrTySig vars poly_ty src_loc)
  49   = [ ClassOpSig v poly_ty noClassOpPragmas src_loc | v <- vars ]
  50
  51 cvInstDeclSig (RdrSpecValSig        sigs) = sigs
  52 cvInstDeclSig (RdrInlineValSig      sig)  = [ sig ]
  53 cvInstDeclSig (RdrDeforestSig       sig)  = [ sig ]
  54 cvInstDeclSig (RdrMagicUnfoldingSig sig)  = [ sig ]
  55 \end{code}
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 Function definitions are restructured here. Each is assumed to be recursive
  64 initially, and non recursive definitions are discovered by the dependency
  65 analyser.
  66
  67 \begin{code}
  68 cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds
  69 cvBinds sf sig_cvtr raw_binding
  70   = cvSepdBinds sf sig_cvtr (sepDeclsForBinds raw_binding)
  71
  72 cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> RdrNameHsBinds
  73 cvSepdBinds sf sig_cvtr bindings
  74   = case (mkMonoBindsAndSigs sf sig_cvtr bindings) of { (mbs, sigs) ->
  75     if (null sigs)
  76     then SingleBind (RecBind mbs)
  77     else BindWith   (RecBind mbs) sigs
  78     }
  79
  80 cvMonoBinds :: SrcFile -> [RdrBinding] -> RdrNameMonoBinds
  81 cvMonoBinds sf bindings
  82   = case (mkMonoBindsAndSigs sf bottom bindings) of { (mbs,sigs) ->
  83     if (null sigs)
  84     then mbs
  85     else panic "cvMonoBinds: some sigs present"
  86     }
  87   where
  88     bottom = panic "cvMonoBinds: sig converter!"
  89 \end{code}
  90
  91 \begin{code}
  92 mkMonoBindsAndSigs :: SrcFile
  93                    -> SigConverter
  94                    -> [RdrBinding]
  95                    -> (RdrNameMonoBinds, [RdrNameSig])
  96
  97 mkMonoBindsAndSigs sf sig_cvtr fbs
  98   = foldl mangle_bind (EmptyMonoBinds, []) fbs
  99   where
 100     -- If the function being bound has at least one argument, then the
 101     -- guarded right hand sides of each pattern binding are knitted
 102     -- into a series of patterns, each matched with its corresponding
 103     -- guarded right hand side (which may contain several
 104     -- alternatives). This series is then paired with the name of the
 105     -- function. Otherwise there is only one pattern, which is paired
 106     -- with a guarded right hand side.
 107
 108     mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _)
 109       = (b_acc, s_acc ++ sig_cvtr sig)
 110
 111     mangle_bind (b_acc, s_acc) (RdrSpecValSig        sig) = (b_acc, sig ++ s_acc)
 112     mangle_bind (b_acc, s_acc) (RdrInlineValSig      sig) = (b_acc, sig : s_acc)
 113     mangle_bind (b_acc, s_acc) (RdrDeforestSig       sig) = (b_acc, sig : s_acc)
 114     mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc)
 115
 116     mangle_bind (b_acc, s_acc)
 117                 (RdrPatternBinding lousy_srcline [patbinding])
 118       -- WDP: the parser has trouble getting a good line-number on RdrPatternBindings.
 119       = case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) ->
 120         let
 121             src_loc = mkSrcLoc2 sf good_srcline
 122         in
 123         (b_acc `AndMonoBinds`
 124          PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc)
 125         }
 126       where
 127         good_srcline = case patbinding of
 128                          RdrMatch_NoGuard ln _ _ _ _ -> ln
 129                          RdrMatch_Guards  ln _ _ _ _ -> ln
 130
 131
 132     mangle_bind _ (RdrPatternBinding _ _)
 133       = panic "mangleBinding: more than one pattern on a RdrPatternBinding"
 134
 135     mangle_bind (b_acc, s_acc) (RdrFunctionBinding srcline patbindings)
 136             -- must be a function binding...
 137       = case (cvFunMonoBind sf patbindings) of { (var, matches) ->
 138         (b_acc `AndMonoBinds`
 139          FunMonoBind var matches (mkSrcLoc2 sf srcline), s_acc)
 140         }
 141 \end{code}
 142
 143 \begin{code}
 144 cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds)
 145
 146 cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
 147   = (pat, [OtherwiseGRHS expr (mkSrcLoc2 sf srcline)], cvBinds sf cvValSig binding)
 148
 149 cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding)
 150   = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding)
 151
 152 cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, [RdrNameMatch])
 153
 154 cvFunMonoBind sf matches
 155   = (srcfun {- cheating ... -}, cvMatches sf False matches)
 156   where
 157     srcfun = case (head matches) of
 158                RdrMatch_NoGuard _ sfun _ _ _ -> sfun
 159                RdrMatch_Guards  _ sfun _ _ _ -> sfun
 160
 161 cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch]
 162 cvMatch   :: SrcFile -> Bool -> RdrMatch   -> RdrNameMatch
 163
 164 cvMatches sf is_case matches = map (cvMatch sf is_case) matches
 165
 166 cvMatch sf is_case rdr_match
 167   = foldr PatMatch
 168           (GRHSMatch (GRHSsAndBindsIn guarded_exprs (cvBinds sf cvValSig binding)))
 169
 170           -- For a FunMonoBinds, the first flattened "pattern" is
 171           -- just the function name, and we don't want to keep it.
 172           -- For a case expr, it's (presumably) a constructor name -- and
 173           -- we most certainly want to keep it!  Hence the monkey busines...
 174
 175           (if is_case then -- just one pattern: leave it untouched...
 176               [pat']
 177            else
 178               case pat' of
 179                 ConPatIn _ pats -> pats
 180           )
 181   where
 182     (pat, binding, guarded_exprs)
 183       = case rdr_match of
 184           RdrMatch_NoGuard ln b c expr    d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc2 sf ln)])
 185           RdrMatch_Guards  ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
 186
 187     ---------------------
 188     pat' = doctor_pat pat
 189
 190     -- a ConOpPatIn in the corner may be handled by converting it to
 191     -- ConPatIn...
 192
 193     doctor_pat (ConOpPatIn p1 op p2) = ConPatIn op [p1, p2]
 194     doctor_pat other_pat             = other_pat
 195
 196 cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS
 197
 198 cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl)
 199 \end{code}
 200
 201 %************************************************************************
 202 %*                                                                      *
 203 \subsection[PrefixToHS-utils]{Utilities for conversion}
 204 %*                                                                      *
 205 %************************************************************************
 206
 207 Separate declarations into all the various kinds:
 208 \begin{display}
 209 tys             RdrTyDecl
 210 ty "sigs"       RdrSpecDataSig
 211 classes         RdrClassDecl
 212 insts           RdrInstDecl
 213 inst "sigs"     RdrSpecInstSig
 214 defaults        RdrDefaultDecl
 215 binds           RdrFunctionBinding RdrPatternBinding RdrTySig
 216                 RdrSpecValSig RdrInlineValSig RdrDeforestSig
 217                 RdrMagicUnfoldingSig
 218 \end{display}
 219
 220 This function isn't called directly; some other function calls it,
 221 then checks that what it got is appropriate for that situation.
 222 (Those functions follow...)
 223
 224 \begin{code}
 225 sepDecls (RdrTyDecl a)
 226          tys tysigs classes insts instsigs defaults binds
 227  = (a:tys,tysigs,classes,insts,instsigs,defaults,binds)
 228
 229 sepDecls a@(RdrFunctionBinding _ _)
 230          tys tysigs classes insts instsigs defaults binds
 231  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 232
 233 sepDecls a@(RdrPatternBinding _ _)
 234          tys tysigs classes insts instsigs defaults binds
 235  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 236
 237 -- RdrAndBindings catered for below...
 238
 239 sepDecls (RdrClassDecl a)
 240          tys tysigs classes insts instsigs defaults binds
 241   = (tys,tysigs,a:classes,insts,instsigs,defaults,binds)
 242
 243 sepDecls (RdrInstDecl a)
 244          tys tysigs classes insts instsigs defaults binds
 245   = (tys,tysigs,classes,a:insts,instsigs,defaults,binds)
 246
 247 sepDecls (RdrDefaultDecl a)
 248          tys tysigs classes insts instsigs defaults binds
 249   = (tys,tysigs,classes,insts,instsigs,a:defaults,binds)
 250
 251 sepDecls a@(RdrTySig _ _ _)
 252          tys tysigs classes insts instsigs defaults binds
 253   = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 254
 255 sepDecls a@(RdrSpecValSig _)
 256          tys tysigs classes insts instsigs defaults binds
 257   = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 258
 259 sepDecls a@(RdrInlineValSig _)
 260          tys tysigs classes insts instsigs defaults binds
 261   = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 262
 263 sepDecls a@(RdrDeforestSig _)
 264          tys tysigs classes insts instsigs defaults binds
 265   = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 266
 267 sepDecls a@(RdrMagicUnfoldingSig _)
 268          tys tysigs classes insts instsigs defaults binds
 269   = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 270
 271 sepDecls (RdrSpecInstSig a)
 272          tys tysigs classes insts instsigs defaults binds
 273   = (tys,tysigs,classes,insts,a:instsigs,defaults,binds)
 274
 275 sepDecls (RdrSpecDataSig a)
 276          tys tysigs classes insts instsigs defaults binds
 277   = (tys,a:tysigs,classes,insts,instsigs,defaults,binds)
 278
 279 sepDecls RdrNullBind
 280          tys tysigs classes insts instsigs defaults binds
 281   = (tys,tysigs,classes,insts,instsigs,defaults,binds)
 282
 283 sepDecls (RdrAndBindings bs1 bs2)
 284          tys tysigs classes insts instsigs defaults binds
 285   = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds) of {
 286       (tys,tysigs,classes,insts,instsigs,defaults,binds) ->
 287           sepDecls bs1 tys tysigs classes insts instsigs defaults binds
 288     }
 289 \end{code}
 290
 291 \begin{code}
 292 sepDeclsForTopBinds binding
 293   = sepDecls binding [] [] [] [] [] [] []
 294
 295 sepDeclsForBinds binding
 296   = case (sepDecls binding [] [] [] [] [] [] [])
 297         of { (tys,tysigs,classes,insts,instsigs,defaults,binds) ->
 298     ASSERT ((null tys)
 299          && (null tysigs)
 300          && (null classes)
 301          && (null insts)
 302          && (null instsigs)
 303          && (null defaults))
 304     binds
 305     }
 306
 307 sepDeclsIntoSigsAndBinds binding
 308   = case (sepDeclsForBinds binding) of { sigs_and_binds ->
 309     foldr sep_stuff ([],[]) sigs_and_binds
 310     }
 311   where
 312     sep_stuff s@(RdrTySig _ _ _)         (sigs,defs) = (s:sigs,defs)
 313     sep_stuff s@(RdrSpecValSig _)        (sigs,defs) = (s:sigs,defs)
 314     sep_stuff s@(RdrInlineValSig _)      (sigs,defs) = (s:sigs,defs)
 315     sep_stuff s@(RdrDeforestSig  _)      (sigs,defs) = (s:sigs,defs)
 316     sep_stuff s@(RdrMagicUnfoldingSig _) (sigs,defs) = (s:sigs,defs)
 317     sep_stuff d@(RdrFunctionBinding _ _) (sigs,defs) = (sigs,d:defs)
 318     sep_stuff d@(RdrPatternBinding  _ _) (sigs,defs) = (sigs,d:defs)
 319
 320
 321 \end{code}