ghc/compiler/deSugar/Desugar.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[Desugar]{@deSugar@: the main function}
   5
   6 \begin{code}
   7 module Desugar ( deSugar ) where
   8
   9 #include "HsVersions.h"
  10
  11 import CmdLineOpts      ( opt_D_dump_ds )
  12 import HsSyn            ( MonoBinds )
  13 import TcHsSyn          ( TypecheckedMonoBinds, TypecheckedForeignDecl )
  14 import CoreSyn
  15 import DsMonad
  16 import DsBinds          ( dsMonoBinds )
  17 import DsForeign        ( dsForeigns )
  18 import DsUtils
  19 import DsExpr           ()      -- Forces DsExpr to be compiled; DsBinds only
  20                                 -- depends on DsExpr.hi-boot.
  21 import Module           ( Module, moduleString )
  22 import Bag              ( isEmptyBag, unionBags )
  23 import CmdLineOpts      ( opt_SccGroup, opt_SccProfilingOn )
  24 import CoreLint         ( beginPass, endPass )
  25 import ErrUtils         ( doIfSet, pprBagOfWarnings )
  26 import Outputable
  27 import UniqSupply       ( splitUniqSupply, UniqSupply )
  28 \end{code}
  29
  30 The only trick here is to get the @DsMonad@ stuff off to a good
  31 start.
  32
  33 \begin{code}
  34 deSugar :: UniqSupply           -- name supply
  35         -> ValueEnv             -- value env
  36         -> Module               -- module name
  37         -> TypecheckedMonoBinds
  38         -> [TypecheckedForeignDecl]
  39         -> IO ([CoreBind], SDoc, SDoc) -- output
  40
  41 deSugar us global_val_env mod_name all_binds fo_decls = do
  42         beginPass "Desugar"
  43         -- Do desugaring
  44         let (core_prs, ds_warns1) = initDs us1 global_val_env module_and_group
  45                                             (dsMonoBinds opt_SccProfilingOn all_binds [])
  46             ds_binds' = [Rec core_prs]
  47
  48             ((fi_binds, fe_binds, h_code, c_code), ds_warns2) =
  49                     initDs us3 global_val_env module_and_group (dsForeigns mod_name fo_decls)
  50
  51             ds_binds  = fi_binds ++ ds_binds' ++ fe_binds
  52
  53             ds_warns = ds_warns1 `unionBags` ds_warns2
  54
  55          -- Display any warnings
  56         doIfSet (not (isEmptyBag ds_warns))
  57                 (printErrs (pprBagOfWarnings ds_warns))
  58
  59          -- Lint result if necessary
  60         endPass "Desugar" opt_D_dump_ds ds_binds
  61         return (ds_binds, h_code, c_code)
  62   where
  63     (us1, us2) = splitUniqSupply us
  64     (us3, us4) = splitUniqSupply us2
  65
  66     module_and_group = (mod_name, grp_name)
  67     grp_name  = case opt_SccGroup of
  68                   Just xx -> _PK_ xx
  69                   Nothing -> _PK_ (moduleString mod_name)       -- default: module name
  70
  71 \end{code}