ghc/compiler/reader/PrefixToHs.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   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 module PrefixToHs (
  10         cvValSig,
  11         cvClassOpSig,
  12         cvInstDeclSig,
  13
  14         cvBinds,
  15         cvMonoBindsAndSigs,
  16         cvMatches,
  17         cvOtherDecls,
  18         cvForeignDecls -- HACK
  19
  20     ) where
  21
  22 #include "HsVersions.h"
  23
  24 import PrefixSyn        -- and various syntaxen.
  25 import HsSyn
  26 import RdrHsSyn
  27
  28 import BasicTypes       ( RecFlag(..) )
  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
  42 \begin{code}
  43 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
  44
  45 cvValSig      sig = sig
  46
  47 cvInstDeclSig sig = sig
  48
  49 cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
  50 cvClassOpSig sig                       = sig
  51 \end{code}
  52
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 Function definitions are restructured here. Each is assumed to be recursive
  61 initially, and non recursive definitions are discovered by the dependency
  62 analyser.
  63
  64 \begin{code}
  65 cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds
  66 cvBinds sf sig_cvtr binding
  67   = case (cvMonoBindsAndSigs sf sig_cvtr binding) of { (mbs, sigs) ->
  68     MonoBind mbs sigs Recursive
  69     }
  70 \end{code}
  71
  72 \begin{code}
  73 cvMonoBindsAndSigs :: SrcFile
  74                    -> SigConverter
  75                    -> RdrBinding
  76                    -> (RdrNameMonoBinds, [RdrNameSig])
  77
  78 cvMonoBindsAndSigs sf sig_cvtr fb
  79   = mangle_bind (EmptyMonoBinds, []) fb
  80   where
  81     -- If the function being bound has at least one argument, then the
  82     -- guarded right hand sides of each pattern binding are knitted
  83     -- into a series of patterns, each matched with its corresponding
  84     -- guarded right hand side (which may contain several
  85     -- alternatives). This series is then paired with the name of the
  86     -- function. Otherwise there is only one pattern, which is paired
  87     -- with a guarded right hand side.
  88
  89     mangle_bind acc (RdrAndBindings fb1 fb2)
  90       = mangle_bind (mangle_bind acc fb1) fb2
  91
  92     mangle_bind (b_acc, s_acc) (RdrSig sig)
  93       = (b_acc, sig_cvtr sig : s_acc)
  94
  95     mangle_bind (b_acc, s_acc)
  96                 (RdrPatternBinding lousy_srcline [patbinding])
  97       -- WDP: the parser has trouble getting a good line-number on RdrPatternBindings.
  98       = case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) ->
  99         let
 100             src_loc = mkSrcLoc sf good_srcline
 101         in
 102         (b_acc `AndMonoBinds`
 103          PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc)
 104         }
 105       where
 106         good_srcline = case patbinding of
 107                          RdrMatch_NoGuard ln _ _ _ _ -> ln
 108                          RdrMatch_Guards  ln _ _ _ _ -> ln
 109
 110
 111     mangle_bind _ (RdrPatternBinding _ _)
 112       = panic "mangleBinding: more than one pattern on a RdrPatternBinding"
 113
 114     mangle_bind (b_acc, s_acc) (RdrFunctionBinding srcline patbindings)
 115             -- must be a function binding...
 116       = case (cvFunMonoBind sf patbindings) of { (var, inf, matches) ->
 117         (b_acc `AndMonoBinds`
 118          FunMonoBind var inf matches (mkSrcLoc sf srcline), s_acc)
 119         }
 120
 121     mangle_bind (b_acc, s_acc) other = (b_acc, s_acc)
 122         -- Ignore class decls, instance decls etc
 123 \end{code}
 124
 125 \begin{code}
 126 cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds)
 127
 128 cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
 129   = (pat, unguardedRHS expr (mkSrcLoc sf srcline), cvBinds sf cvValSig binding)
 130
 131 cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding)
 132   = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding)
 133
 134 cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, Bool {-InfixDefn-}, [RdrNameMatch])
 135
 136 cvFunMonoBind sf matches
 137   = (head srcfuns, head infixdefs, cvMatches sf False matches)
 138   where
 139     (srcfuns, infixdefs) = mapAndUnzip get_mdef matches
 140     -- ToDo: Check for consistent srcfun and infixdef
 141
 142     get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat
 143     get_mdef (RdrMatch_Guards  _ sfun pat _ _) = get_pdef pat
 144
 145     get_pdef (ConPatIn fn _)       = (fn, False)
 146     get_pdef (ConOpPatIn _ op _ _) = (op, True)
 147     get_pdef (ParPatIn pat)        = get_pdef pat
 148
 149
 150 cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch]
 151 cvMatch   :: SrcFile -> Bool -> RdrMatch   -> RdrNameMatch
 152
 153 cvMatches sf is_case matches = map (cvMatch sf is_case) matches
 154
 155 cvMatch sf is_case rdr_match
 156   = foldr PatMatch
 157           (GRHSMatch (GRHSsAndBindsIn guarded_exprs (cvBinds sf cvValSig binding)))
 158
 159           -- For a FunMonoBinds, the first flattened "pattern" is
 160           -- just the function name, and we don't want to keep it.
 161           -- For a case expr, it's (presumably) a constructor name -- and
 162           -- we most certainly want to keep it!  Hence the monkey busines...
 163
 164           (if is_case then -- just one pattern: leave it untouched...
 165               [pat]
 166            else            -- function pattern; extract arg patterns...
 167               case pat of ConPatIn fn pats      -> pats
 168                           ConOpPatIn p1 op _ p2 -> [p1,p2]
 169                           ParPatIn pat          -> panic "PrefixToHs.cvMatch:ParPatIn"
 170           )
 171   where
 172     (pat, binding, guarded_exprs)
 173       = case rdr_match of
 174           RdrMatch_NoGuard ln b c expr    d -> (c,d, unguardedRHS expr (mkSrcLoc sf ln))
 175           RdrMatch_Guards  ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
 176
 177 cvGRHS :: SrcFile -> SrcLine -> ([RdrNameStmt], RdrNameHsExpr) -> RdrNameGRHS
 178 cvGRHS sf sl (g, e) = GRHS (g ++ [ExprStmt e locn]) locn
 179                     where
 180                       locn = mkSrcLoc sf sl
 181 \end{code}
 182
 183 %************************************************************************
 184 %*                                                                      *
 185 \subsection[PrefixToHS-utils]{Utilities for conversion}
 186 %*                                                                      *
 187 %************************************************************************
 188
 189 Separate declarations into all the various kinds:
 190
 191 \begin{code}
 192 cvOtherDecls :: RdrBinding -> [RdrNameHsDecl]
 193 cvOtherDecls b
 194   = go [] b
 195   where
 196     go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
 197     go acc (RdrTyDecl d)          = TyD d   : acc
 198     go acc (RdrClassDecl d)       = ClD d   : acc
 199     go acc (RdrInstDecl d)        = InstD d : acc
 200     go acc (RdrDefaultDecl d)     = DefD d  : acc
 201     go acc other                  = acc
 202         -- Ignore value bindings
 203
 204 cvForeignDecls :: RdrBinding -> [RdrNameHsDecl]
 205 cvForeignDecls b = go [] b
 206  where
 207     go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
 208     go acc (RdrForeignDecl d)     = ForD d  : acc
 209     go acc other                  = acc
 210
 211 \end{code}