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