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