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