ghc/compiler/reader/PrefixToHs.lhs

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