ghc/compiler/deSugar/Desugar.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[Desugar]{@deSugar@: the main function}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Desugar (
  10         deSugar,
  11
  12         -- and to make the interface self-sufficient...
  13         SplitUniqSupply, Binds, Expr, Id, TypecheckedPat,
  14         CoreBinding, GlobalSwitch, SwitchResult,
  15         Bag, DsMatchContext, DsMatchKind
  16     ) where
  17
  18
  19 import AbsSyn           -- the stuff being desugared
  20 import PlainCore        -- the output of desugaring;
  21                         -- importing this module also gets all the
  22                         -- CoreSyn utility functions
  23 import DsMonad          -- the monadery used in the desugarer
  24
  25 import Bag              ( unionBags, Bag )
  26 import CmdLineOpts      ( switchIsOn, GlobalSwitch(..), SwitchResult )
  27 import CoreLift         ( liftCoreBindings )
  28 import CoreLint         ( lintCoreBindings )
  29 import DsBinds          ( dsBinds, dsInstBinds )
  30 import IdEnv
  31 import Pretty           ( PprStyle(..) )
  32 import SplitUniq
  33 import Util
  34 \end{code}
  35
  36 The only trick here is to get the @DesugarMonad@ stuff off to a good
  37 start.
  38
  39 \begin{code}
  40 deSugar :: SplitUniqSupply              -- name supply
  41         -> (GlobalSwitch->SwitchResult) -- switch looker upper
  42         -> FAST_STRING                  -- module name
  43
  44         -> (TypecheckedBinds,   -- input: class, instance, and value
  45             TypecheckedBinds,   --   bindings; see "tcModule" (which produces
  46             TypecheckedBinds,   --   them)
  47             [(Inst, TypecheckedExpr)])
  48 -- ToDo: handling of const_inst thingies is certainly WRONG ***************************
  49
  50         -> ([PlainCoreBinding], -- output
  51             Bag DsMatchContext) -- Shadowing complaints
  52
  53 deSugar us sw_chkr mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs)
  54   = let
  55         (us0, us0a) = splitUniqSupply us
  56         (us1, us1a) = splitUniqSupply us0a
  57         (us2, us2a) = splitUniqSupply us1a
  58         (us3, us4)  = splitUniqSupply us2a
  59
  60         ((core_const_prs, consts_pairs), shadows1)
  61             = initDs us0 nullIdEnv sw_chkr mod_name (dsInstBinds [] const_inst_pairs)
  62
  63         consts_env = mkIdEnv consts_pairs
  64
  65         (core_clas_binds, shadows2)
  66                         = initDs us1 consts_env sw_chkr mod_name (dsBinds clas_binds)
  67         core_clas_prs   = pairsFromCoreBinds core_clas_binds
  68
  69         (core_inst_binds, shadows3)
  70                         = initDs us2 consts_env sw_chkr mod_name (dsBinds inst_binds)
  71         core_inst_prs   = pairsFromCoreBinds core_inst_binds
  72
  73         (core_val_binds, shadows4)
  74                         = initDs us3 consts_env sw_chkr mod_name (dsBinds val_binds)
  75         core_val_pairs  = pairsFromCoreBinds core_val_binds
  76
  77         final_binds
  78           = if (null core_clas_prs && null core_inst_prs && null core_const_prs) then
  79                 -- we don't have to make the whole thing recursive
  80                 core_clas_binds ++ core_val_binds
  81
  82             else -- gotta make it recursive (sigh)
  83                [CoRec (core_clas_prs ++ core_inst_prs ++ core_const_prs ++ core_val_pairs)]
  84
  85         lift_final_binds = {-if switchIsOn sw_chkr GlasgowExts
  86                            then-} liftCoreBindings us4 final_binds
  87                            -- else final_binds
  88
  89         really_final_binds = if switchIsOn sw_chkr DoCoreLinting
  90                              then lintCoreBindings PprDebug "Desugarer" False lift_final_binds
  91                              else lift_final_binds
  92
  93         shadows = shadows1 `unionBags` shadows2 `unionBags` shadows3 `unionBags` shadows4
  94     in
  95     (really_final_binds, shadows)
  96 \end{code}