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