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, DsMatchContext, pprDsWarnings ) where
  10
  11 import Ubiq{-uitous-}
  12
  13 import HsSyn            ( HsBinds, HsExpr )
  14 import TcHsSyn          ( TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
  15 import CoreSyn
  16
  17 import DsMonad
  18 import DsBinds          ( dsBinds, dsInstBinds )
  19 import DsUtils
  20
  21 import Bag              ( unionBags )
  22 import CmdLineOpts      ( opt_DoCoreLinting )
  23 import CoreLift         ( liftCoreBindings )
  24 import CoreLint         ( lintCoreBindings )
  25 import Id               ( nullIdEnv, mkIdEnv )
  26 import PprStyle         ( PprStyle(..) )
  27 import UniqSupply       ( splitUniqSupply )
  28 \end{code}
  29
  30 The only trick here is to get the @DsMonad@ stuff off to a good
  31 start.
  32
  33 \begin{code}
  34 deSugar :: UniqSupply           -- name supply
  35         -> FAST_STRING                  -- module name
  36
  37         -> (TypecheckedHsBinds,   -- input: class, instance, and value
  38             TypecheckedHsBinds, --   bindings; see "tcModule" (which produces
  39             TypecheckedHsBinds, --   them)
  40             [(Id, TypecheckedHsExpr)])
  41 -- ToDo: handling of const_inst thingies is certainly WRONG ***************************
  42
  43         -> ([CoreBinding],      -- output
  44             Bag DsMatchContext) -- Shadowing complaints
  45
  46 deSugar us mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs)
  47   = let
  48         (us0, us0a) = splitUniqSupply us
  49         (us1, us1a) = splitUniqSupply us0a
  50         (us2, us2a) = splitUniqSupply us1a
  51         (us3, us4)  = splitUniqSupply us2a
  52
  53         ((core_const_prs, consts_pairs), shadows1)
  54             = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs)
  55
  56         consts_env = mkIdEnv consts_pairs
  57
  58         (core_clas_binds, shadows2)
  59                         = initDs us1 consts_env mod_name (dsBinds clas_binds)
  60         core_clas_prs   = pairsFromCoreBinds core_clas_binds
  61
  62         (core_inst_binds, shadows3)
  63                         = initDs us2 consts_env mod_name (dsBinds inst_binds)
  64         core_inst_prs   = pairsFromCoreBinds core_inst_binds
  65
  66         (core_val_binds, shadows4)
  67                         = initDs us3 consts_env mod_name (dsBinds val_binds)
  68         core_val_pairs  = pairsFromCoreBinds core_val_binds
  69
  70         final_binds
  71           = if (null core_clas_prs && null core_inst_prs && null core_const_prs) then
  72                 -- we don't have to make the whole thing recursive
  73                 core_clas_binds ++ core_val_binds
  74
  75             else -- gotta make it recursive (sigh)
  76                [Rec (core_clas_prs ++ core_inst_prs ++ core_const_prs ++ core_val_pairs)]
  77
  78         lift_final_binds = liftCoreBindings us4 final_binds
  79
  80         really_final_binds = if opt_DoCoreLinting
  81                              then lintCoreBindings PprDebug "Desugarer" False lift_final_binds
  82                              else lift_final_binds
  83
  84         shadows = shadows1 `unionBags` shadows2 `unionBags` shadows3 `unionBags` shadows4
  85     in
  86     (really_final_binds, shadows)
  87 \end{code}