ghc/compiler/deSugar/Desugar.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Desugar]{@deSugar@: the main function}
   5
   6 \begin{code}
   7 module Desugar ( deSugar, pprDsWarnings ) where
   8
   9 #include "HsVersions.h"
  10
  11 import CmdLineOpts      ( opt_D_dump_ds )
  12 import HsSyn            ( HsBinds, HsExpr, MonoBinds
  13                         )
  14 import TcHsSyn          ( TypecheckedMonoBinds, TypecheckedHsExpr
  15                         )
  16 import CoreSyn
  17 import PprCore          ( pprCoreBindings )
  18 import Name             ( isExported )
  19 import DsMonad
  20 import DsBinds          ( dsMonoBinds )
  21 import DsUtils
  22
  23 import Bag              ( unionBags, isEmptyBag )
  24 import BasicTypes       ( Module, RecFlag(..) )
  25 import CmdLineOpts      ( opt_DoCoreLinting, opt_SccGroup, opt_SccProfilingOn )
  26 import CostCentre       ( IsCafCC(..), mkAutoCC )
  27 import CoreLift         ( liftCoreBindings )
  28 import CoreLint         ( lintCoreBindings )
  29 import Id               ( nullIdEnv, mkIdEnv, idType,
  30                           DictVar, GenId, Id )
  31 import ErrUtils         ( dumpIfSet, doIfSet )
  32 import Outputable
  33 import UniqSupply       ( splitUniqSupply, UniqSupply )
  34 \end{code}
  35
  36 The only trick here is to get the @DsMonad@ stuff off to a good
  37 start.
  38
  39 \begin{code}
  40 deSugar :: UniqSupply           -- name supply
  41         -> Module               -- module name
  42         -> TypecheckedMonoBinds
  43         -> IO [CoreBinding]     -- output
  44
  45 deSugar us mod_name all_binds
  46   = let
  47         (us1, us2) = splitUniqSupply us
  48
  49         module_and_group = (mod_name, grp_name)
  50         grp_name  = case opt_SccGroup of
  51                         Just xx -> _PK_ xx
  52                         Nothing -> mod_name     -- default: module name
  53
  54         (core_prs, ds_warns) = initDs us1 nullIdEnv module_and_group
  55                                (dsMonoBinds opt_SccProfilingOn all_binds [])
  56
  57         ds_binds = liftCoreBindings us2 [Rec core_prs]
  58     in
  59
  60         -- Display any warnings
  61     doIfSet (not (isEmptyBag ds_warns))
  62         (printErrs (pprDsWarnings ds_warns)) >>
  63
  64         -- Lint result if necessary
  65     lintCoreBindings "Desugarer" False ds_binds >>
  66
  67         -- Dump output
  68     dumpIfSet opt_D_dump_ds "Desugared:"
  69         (pprCoreBindings ds_binds)      >>
  70
  71     return ds_binds
  72 \end{code}