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 HsSyn            ( HsBinds, HsExpr, MonoBinds,
  20                           SYN_IE(RecFlag), nonRecursive, recursive
  21                         )
  22 import TcHsSyn          ( SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedHsExpr)
  23                         )
  24 import CoreSyn
  25 import Name             ( isExported )
  26 import DsMonad
  27 import DsBinds          ( dsMonoBinds )
  28 import DsUtils
  29
  30 import Bag              ( unionBags )
  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 Outputable       ( PprStyle(..) )
  39 import UniqSupply       ( splitUniqSupply, UniqSupply )
  40 \end{code}
  41
  42 The only trick here is to get the @DsMonad@ stuff off to a good
  43 start.
  44
  45 \begin{code}
  46 deSugar :: UniqSupply           -- name supply
  47         -> Module               -- module name
  48         -> TypecheckedMonoBinds
  49         -> ([CoreBinding],      -- output
  50             DsWarnings)     -- Shadowing complaints
  51
  52 deSugar us mod_name all_binds
  53   = let
  54         (us1, us2) = splitUniqSupply us
  55
  56         module_and_group = (mod_name, grp_name)
  57         grp_name  = case opt_SccGroup of
  58                         Just xx -> _PK_ xx
  59                         Nothing -> mod_name     -- default: module name
  60
  61         (core_prs, shadows) = initDs us1 nullIdEnv module_and_group
  62                               (dsMonoBinds opt_SccProfilingOn recursive all_binds [])
  63
  64         lift_final_binds = liftCoreBindings us2 [Rec core_prs]
  65
  66         really_final_binds = if opt_DoCoreLinting
  67                              then lintCoreBindings PprDebug "Desugarer" False lift_final_binds
  68                              else lift_final_binds
  69     in
  70     (really_final_binds, shadows)
  71 \end{code}