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 IMP_Ubiq(){-uitous-}
  12
  13 import HsSyn            ( HsBinds, HsExpr )
  14 import TcHsSyn          ( SYN_IE(TypecheckedHsBinds), SYN_IE(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, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
  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: recsel, class, instance, and value
  38             TypecheckedHsBinds, --   bindings; see "tcModule" (which produces
  39             TypecheckedHsBinds, --   them)
  40             TypecheckedHsBinds,
  41             [(Id, TypecheckedHsExpr)])
  42 -- ToDo: handling of const_inst thingies is certainly WRONG ***************************
  43
  44         -> ([CoreBinding],      -- output
  45             Bag DsMatchContext) -- Shadowing complaints
  46
  47 deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_pairs)
  48   = let
  49         (us0, us0a) = splitUniqSupply us
  50         (us1, us1a) = splitUniqSupply us0a
  51         (us2, us2a) = splitUniqSupply us1a
  52         (us3, us3a) = splitUniqSupply us2a
  53         (us4, us5)  = splitUniqSupply us3a
  54
  55         auto_meth = opt_AutoSccsOnAllToplevs
  56         auto_top  = opt_AutoSccsOnAllToplevs
  57                     || opt_AutoSccsOnExportedToplevs
  58
  59         ((core_const_prs, consts_pairs), shadows1)
  60             = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs)
  61
  62         consts_env = mkIdEnv consts_pairs
  63
  64         (core_clas_binds, shadows2)
  65                         = initDs us1 consts_env mod_name (dsBinds False clas_binds)
  66         core_clas_prs   = pairsFromCoreBinds core_clas_binds
  67
  68         (core_inst_binds, shadows3)
  69                         = initDs us2 consts_env mod_name (dsBinds auto_meth inst_binds)
  70         core_inst_prs   = pairsFromCoreBinds core_inst_binds
  71
  72         (core_val_binds, shadows4)
  73                         = initDs us3 consts_env mod_name (dsBinds auto_top val_binds)
  74         core_val_pairs  = pairsFromCoreBinds core_val_binds
  75
  76         (core_recsel_binds, shadows5)
  77                         = initDs us4 consts_env mod_name (dsBinds ({-trace "Desugar:core_recsel_binds"-} False) recsel_binds)
  78         core_recsel_prs = pairsFromCoreBinds core_recsel_binds
  79
  80         final_binds
  81           = if (null core_clas_prs && null core_inst_prs
  82              && null core_recsel_prs {-???dont know???-} && null core_const_prs) then
  83                 -- we don't have to make the whole thing recursive
  84                 core_clas_binds ++ core_val_binds
  85
  86             else -- gotta make it recursive (sigh)
  87                [Rec (core_clas_prs ++ core_inst_prs
  88                   ++ core_const_prs ++ core_val_pairs ++ core_recsel_prs)]
  89
  90         lift_final_binds = liftCoreBindings us5 final_binds
  91
  92         really_final_binds = if opt_DoCoreLinting
  93                              then lintCoreBindings PprDebug "Desugarer" False lift_final_binds
  94                              else lift_final_binds
  95
  96         shadows = shadows1 `unionBags` shadows2 `unionBags`
  97                   shadows3 `unionBags` shadows4 `unionBags` shadows5
  98     in
  99     (really_final_binds, shadows)
 100 \end{code}