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 IMP_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             ( mapAndUnzip, 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, inf, matches) ->
 138         (b_acc `AndMonoBinds`
 139          FunMonoBind var inf 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-}, Bool {-InfixDefn-}, [RdrNameMatch])
 153
 154 cvFunMonoBind sf matches
 155   = (head srcfuns, head infixdefs, cvMatches sf False matches)
 156   where
 157     (srcfuns, infixdefs) = mapAndUnzip get_mdef matches
 158     -- ToDo: Check for consistent srcfun and infixdef
 159
 160     get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat
 161     get_mdef (RdrMatch_Guards  _ sfun pat _ _) = get_pdef pat
 162
 163     get_pdef (ConPatIn fn _)     = (fn, False)
 164     get_pdef (ConOpPatIn _ op _) = (op, True)
 165     get_pdef (ParPatIn pat)      = get_pdef pat
 166
 167
 168 cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch]
 169 cvMatch   :: SrcFile -> Bool -> RdrMatch   -> RdrNameMatch
 170
 171 cvMatches sf is_case matches = map (cvMatch sf is_case) matches
 172
 173 cvMatch sf is_case rdr_match
 174   = foldr PatMatch
 175           (GRHSMatch (GRHSsAndBindsIn guarded_exprs (cvBinds sf cvValSig binding)))
 176
 177           -- For a FunMonoBinds, the first flattened "pattern" is
 178           -- just the function name, and we don't want to keep it.
 179           -- For a case expr, it's (presumably) a constructor name -- and
 180           -- we most certainly want to keep it!  Hence the monkey busines...
 181
 182           (if is_case then -- just one pattern: leave it untouched...
 183               [pat]
 184            else            -- function pattern; extract arg patterns...
 185               case pat of ConPatIn fn pats    -> pats
 186                           ConOpPatIn p1 op p2 -> [p1,p2]
 187                           ParPatIn pat        -> panic "PrefixToHs.cvMatch:ParPatIn"
 188           )
 189   where
 190     (pat, binding, guarded_exprs)
 191       = case rdr_match of
 192           RdrMatch_NoGuard ln b c expr    d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc2 sf ln)])
 193           RdrMatch_Guards  ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
 194
 195 cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS
 196 cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl)
 197 \end{code}
 198
 199 %************************************************************************
 200 %*                                                                      *
 201 \subsection[PrefixToHS-utils]{Utilities for conversion}
 202 %*                                                                      *
 203 %************************************************************************
 204
 205 Separate declarations into all the various kinds:
 206 \begin{display}
 207 tys             RdrTyDecl
 208 ty "sigs"       RdrSpecDataSig
 209 classes         RdrClassDecl
 210 insts           RdrInstDecl
 211 inst "sigs"     RdrSpecInstSig
 212 defaults        RdrDefaultDecl
 213 binds           RdrFunctionBinding RdrPatternBinding RdrTySig
 214                 RdrSpecValSig RdrInlineValSig RdrDeforestSig
 215                 RdrMagicUnfoldingSig
 216 \end{display}
 217
 218 This function isn't called directly; some other function calls it,
 219 then checks that what it got is appropriate for that situation.
 220 (Those functions follow...)
 221
 222 \begin{code}
 223 sepDecls (RdrTyDecl a)
 224          tys tysigs classes insts instsigs defaults binds
 225  = (a:tys,tysigs,classes,insts,instsigs,defaults,binds)
 226
 227 sepDecls a@(RdrFunctionBinding _ _)
 228          tys tysigs classes insts instsigs defaults binds
 229  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 230
 231 sepDecls a@(RdrPatternBinding _ _)
 232          tys tysigs classes insts instsigs defaults binds
 233  = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 234
 235 -- RdrAndBindings catered for below...
 236
 237 sepDecls (RdrClassDecl a)
 238          tys tysigs classes insts instsigs defaults binds
 239   = (tys,tysigs,a:classes,insts,instsigs,defaults,binds)
 240
 241 sepDecls (RdrInstDecl a)
 242          tys tysigs classes insts instsigs defaults binds
 243   = (tys,tysigs,classes,a:insts,instsigs,defaults,binds)
 244
 245 sepDecls (RdrDefaultDecl a)
 246          tys tysigs classes insts instsigs defaults binds
 247   = (tys,tysigs,classes,insts,instsigs,a:defaults,binds)
 248
 249 sepDecls a@(RdrTySig _ _ _)
 250          tys tysigs classes insts instsigs defaults binds
 251   = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 252
 253 sepDecls a@(RdrSpecValSig _)
 254          tys tysigs classes insts instsigs defaults binds
 255   = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 256
 257 sepDecls a@(RdrInlineValSig _)
 258          tys tysigs classes insts instsigs defaults binds
 259   = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 260
 261 sepDecls a@(RdrDeforestSig _)
 262          tys tysigs classes insts instsigs defaults binds
 263   = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 264
 265 sepDecls a@(RdrMagicUnfoldingSig _)
 266          tys tysigs classes insts instsigs defaults binds
 267   = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
 268
 269 sepDecls (RdrSpecInstSig a)
 270          tys tysigs classes insts instsigs defaults binds
 271   = (tys,tysigs,classes,insts,a:instsigs,defaults,binds)
 272
 273 sepDecls (RdrSpecDataSig a)
 274          tys tysigs classes insts instsigs defaults binds
 275   = (tys,a:tysigs,classes,insts,instsigs,defaults,binds)
 276
 277 sepDecls RdrNullBind
 278          tys tysigs classes insts instsigs defaults binds
 279   = (tys,tysigs,classes,insts,instsigs,defaults,binds)
 280
 281 sepDecls (RdrAndBindings bs1 bs2)
 282          tys tysigs classes insts instsigs defaults binds
 283   = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds) of {
 284       (tys,tysigs,classes,insts,instsigs,defaults,binds) ->
 285           sepDecls bs1 tys tysigs classes insts instsigs defaults binds
 286     }
 287 \end{code}
 288
 289 \begin{code}
 290 sepDeclsForTopBinds binding
 291   = sepDecls binding [] [] [] [] [] [] []
 292
 293 sepDeclsForBinds binding
 294   = case (sepDecls binding [] [] [] [] [] [] [])
 295         of { (tys,tysigs,classes,insts,instsigs,defaults,binds) ->
 296     ASSERT ((null tys)
 297          && (null tysigs)
 298          && (null classes)
 299          && (null insts)
 300          && (null instsigs)
 301          && (null defaults))
 302     binds
 303     }
 304
 305 sepDeclsIntoSigsAndBinds binding
 306   = case (sepDeclsForBinds binding) of { sigs_and_binds ->
 307     foldr sep_stuff ([],[]) sigs_and_binds
 308     }
 309   where
 310     sep_stuff s@(RdrTySig _ _ _)         (sigs,defs) = (s:sigs,defs)
 311     sep_stuff s@(RdrSpecValSig _)        (sigs,defs) = (s:sigs,defs)
 312     sep_stuff s@(RdrInlineValSig _)      (sigs,defs) = (s:sigs,defs)
 313     sep_stuff s@(RdrDeforestSig  _)      (sigs,defs) = (s:sigs,defs)
 314     sep_stuff s@(RdrMagicUnfoldingSig _) (sigs,defs) = (s:sigs,defs)
 315     sep_stuff d@(RdrFunctionBinding _ _) (sigs,defs) = (sigs,d:defs)
 316     sep_stuff d@(RdrPatternBinding  _ _) (sigs,defs) = (sigs,d:defs)
 317
 318
 319 \end{code}