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