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 poly_ty noClassOpPragmas 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     if (null sigs)
  71     then SingleBind (RecBind mbs)
  72     else BindWith   (RecBind mbs) sigs
  73     }
  74 \end{code}
  75
  76 \begin{code}
  77 cvMonoBindsAndSigs :: SrcFile
  78                    -> SigConverter
  79                    -> RdrBinding
  80                    -> (RdrNameMonoBinds, [RdrNameSig])
  81
  82 cvMonoBindsAndSigs sf sig_cvtr fb
  83   = mangle_bind (EmptyMonoBinds, []) fb
  84   where
  85     -- If the function being bound has at least one argument, then the
  86     -- guarded right hand sides of each pattern binding are knitted
  87     -- into a series of patterns, each matched with its corresponding
  88     -- guarded right hand side (which may contain several
  89     -- alternatives). This series is then paired with the name of the
  90     -- function. Otherwise there is only one pattern, which is paired
  91     -- with a guarded right hand side.
  92
  93     mangle_bind acc (RdrAndBindings fb1 fb2)
  94       = mangle_bind (mangle_bind acc fb1) fb2
  95
  96     mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _)
  97       = (b_acc, s_acc ++ sig_cvtr sig)
  98
  99     mangle_bind (b_acc, s_acc) (RdrSpecValSig        sig) = (b_acc, sig ++ s_acc)
 100     mangle_bind (b_acc, s_acc) (RdrInlineValSig      sig) = (b_acc, sig : s_acc)
 101     mangle_bind (b_acc, s_acc) (RdrDeforestSig       sig) = (b_acc, sig : s_acc)
 102     mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc)
 103
 104     mangle_bind (b_acc, s_acc)
 105                 (RdrPatternBinding lousy_srcline [patbinding])
 106       -- WDP: the parser has trouble getting a good line-number on RdrPatternBindings.
 107       = case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) ->
 108         let
 109             src_loc = mkSrcLoc sf good_srcline
 110         in
 111         (b_acc `AndMonoBinds`
 112          PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc)
 113         }
 114       where
 115         good_srcline = case patbinding of
 116                          RdrMatch_NoGuard ln _ _ _ _ -> ln
 117                          RdrMatch_Guards  ln _ _ _ _ -> ln
 118
 119
 120     mangle_bind _ (RdrPatternBinding _ _)
 121       = panic "mangleBinding: more than one pattern on a RdrPatternBinding"
 122
 123     mangle_bind (b_acc, s_acc) (RdrFunctionBinding srcline patbindings)
 124             -- must be a function binding...
 125       = case (cvFunMonoBind sf patbindings) of { (var, inf, matches) ->
 126         (b_acc `AndMonoBinds`
 127          FunMonoBind var inf matches (mkSrcLoc sf srcline), s_acc)
 128         }
 129
 130     mangle_bind (b_acc, s_acc) other = (b_acc, s_acc)
 131 \end{code}
 132
 133 \begin{code}
 134 cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds)
 135
 136 cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
 137   = (pat, [OtherwiseGRHS expr (mkSrcLoc sf srcline)], cvBinds sf cvValSig binding)
 138
 139 cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding)
 140   = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding)
 141
 142 cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, Bool {-InfixDefn-}, [RdrNameMatch])
 143
 144 cvFunMonoBind sf matches
 145   = (head srcfuns, head infixdefs, cvMatches sf False matches)
 146   where
 147     (srcfuns, infixdefs) = mapAndUnzip get_mdef matches
 148     -- ToDo: Check for consistent srcfun and infixdef
 149
 150     get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat
 151     get_mdef (RdrMatch_Guards  _ sfun pat _ _) = get_pdef pat
 152
 153     get_pdef (ConPatIn fn _)       = (fn, False)
 154     get_pdef (ConOpPatIn _ op _ _) = (op, True)
 155     get_pdef (ParPatIn pat)        = get_pdef pat
 156
 157
 158 cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch]
 159 cvMatch   :: SrcFile -> Bool -> RdrMatch   -> RdrNameMatch
 160
 161 cvMatches sf is_case matches = map (cvMatch sf is_case) matches
 162
 163 cvMatch sf is_case rdr_match
 164   = foldr PatMatch
 165           (GRHSMatch (GRHSsAndBindsIn guarded_exprs (cvBinds sf cvValSig binding)))
 166
 167           -- For a FunMonoBinds, the first flattened "pattern" is
 168           -- just the function name, and we don't want to keep it.
 169           -- For a case expr, it's (presumably) a constructor name -- and
 170           -- we most certainly want to keep it!  Hence the monkey busines...
 171
 172           (if is_case then -- just one pattern: leave it untouched...
 173               [pat]
 174            else            -- function pattern; extract arg patterns...
 175               case pat of ConPatIn fn pats      -> pats
 176                           ConOpPatIn p1 op _ p2 -> [p1,p2]
 177                           ParPatIn pat          -> panic "PrefixToHs.cvMatch:ParPatIn"
 178           )
 179   where
 180     (pat, binding, guarded_exprs)
 181       = case rdr_match of
 182           RdrMatch_NoGuard ln b c expr    d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc sf ln)])
 183           RdrMatch_Guards  ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
 184
 185 cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS
 186 cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc sf sl)
 187 \end{code}
 188
 189 %************************************************************************
 190 %*                                                                      *
 191 \subsection[PrefixToHS-utils]{Utilities for conversion}
 192 %*                                                                      *
 193 %************************************************************************
 194
 195 Separate declarations into all the various kinds:
 196
 197 \begin{code}
 198 cvOtherDecls :: RdrBinding -> [RdrNameHsDecl]
 199 cvOtherDecls b
 200   = go [] b
 201   where
 202     go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
 203     go acc (RdrTyDecl d)          = TyD d   : acc
 204     go acc (RdrClassDecl d)       = ClD d   : acc
 205     go acc (RdrInstDecl d)        = InstD d : acc
 206     go acc (RdrDefaultDecl d)     = DefD d  : acc
 207     go acc other                  = acc
 208 \end{code}