compiler/deSugar/Desugar.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 The Desugarer: turning HsSyn into Core.
   7
   8 \begin{code}
   9 module Desugar ( deSugar, deSugarExpr ) where
  10
  11 import DynFlags
  12 import StaticFlags
  13 import HscTypes
  14 import HsSyn
  15 import TcRnTypes
  16 import MkIface
  17 import Id
  18 import Name
  19 import CoreSyn
  20 import CoreSubst
  21 import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
  22 import PprCore
  23 import DsMonad
  24 import DsExpr
  25 import DsBinds
  26 import DsForeign
  27 import DsExpr           ()      -- Forces DsExpr to be compiled; DsBinds only
  28                                 -- depends on DsExpr.hi-boot.
  29 import Module
  30 import RdrName
  31 import NameSet
  32 import NameEnv
  33 import Rules
  34 import CoreMonad        ( endPass, CoreToDo(..) )
  35 import ErrUtils
  36 import Outputable
  37 import SrcLoc
  38 import Coverage
  39 import Util
  40 import MonadUtils
  41 import OrdList
  42 import Data.List
  43 import Data.IORef
  44 import PrelNames
  45 import UniqSupply
  46 \end{code}
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 %*              The main function: deSugar
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 \begin{code}
  55 -- | Main entry point to the desugarer.
  56 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
  57 -- Can modify PCS by faulting in more declarations
  58
  59 deSugar hsc_env
  60         mod_loc
  61         tcg_env@(TcGblEnv { tcg_mod          = mod,
  62                             tcg_src          = hsc_src,
  63                             tcg_type_env     = type_env,
  64                             tcg_imports      = imports,
  65                             tcg_exports      = exports,
  66                             tcg_keep         = keep_var,
  67                             tcg_rdr_env      = rdr_env,
  68                             tcg_fix_env      = fix_env,
  69                             tcg_inst_env     = inst_env,
  70                             tcg_fam_inst_env = fam_inst_env,
  71                             tcg_warns        = warns,
  72                             tcg_anns         = anns,
  73                             tcg_binds        = binds,
  74                             tcg_imp_specs    = imp_specs,
  75                             tcg_ev_binds     = ev_binds,
  76                             tcg_fords        = fords,
  77                             tcg_rules        = rules,
  78                             tcg_vects        = vects,
  79                             tcg_insts        = insts,
  80                             tcg_fam_insts    = fam_insts,
  81                             tcg_hpc          = other_hpc_info })
  82
  83   = do  { let dflags = hsc_dflags hsc_env
  84         ; showPass dflags "Desugar"
  85
  86         -- Desugar the program
  87         ; let export_set = availsToNameSet exports
  88         ; let auto_scc = mkAutoScc dflags mod export_set
  89         ; let target = hscTarget dflags
  90         ; let hpcInfo = emptyHpcInfo other_hpc_info
  91         ; (msgs, mb_res)
  92               <- case target of
  93                    HscNothing ->
  94                        return (emptyMessages,
  95                                Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined
  96                                     , undefined
  97                                     , undefined
  98                                     , undefined
  99                                     , undefined
 100                                     , undefined
 101                                     , undefined
 102                                     , undefined
 103                                     , undefined
 104                                     , undefined
 105                                     , undefined
 106                                     , undefined
 107                                     , undefined
 108                                     , undefined
 109                                     , undefined
 110                                     , undefined
 111                                     , undefined
 112                                     , undefined
 113                                     , undefined
 114                                     , undefined
 115                                     , undefined
 116                                     , undefined
 117                                     , undefined
 118                                     , undefined
 119                                     , undefined
 120                                ))
 121                    _        -> do
 122                      (binds_cvr,ds_hpc_info, modBreaks)
 123                          <- if (opt_Hpc
 124                                   || target == HscInterpreted)
 125                                && (not (isHsBoot hsc_src))
 126                               then addCoverageTicksToBinds dflags mod mod_loc
 127                                                            (typeEnvTyCons type_env) binds
 128                               else return (binds, hpcInfo, emptyModBreaks)
 129                      initDs hsc_env mod rdr_env type_env $ do
 130                        do { ds_ev_binds <- dsEvBinds ev_binds
 131                           ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
 132                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
 133                           ; (ds_fords, foreign_prs) <- dsForeigns fords
 134                           ; ds_rules <- mapMaybeM dsRule rules
 135                           ; ds_vects <- mapM dsVect vects
 136                           ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
 137                           ; hetmet_esc  <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name  else return undefined
 138                           ; hetmet_flatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flatten_name else return undefined
 139                           ; hetmet_unflatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_unflatten_name else return undefined
 140                           ; hetmet_flattened_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flattened_id_name else return undefined
 141                           ; hetmet_PGArrow <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_name else return undefined
 142                           ; hetmet_PGArrow_unit <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_unit_name else return undefined
 143                           ; hetmet_PGArrow_tensor <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_tensor_name else return undefined
 144                           ; hetmet_PGArrow_exponent <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_exponent_name else return undefined
 145                           ; hetmet_pga_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_id_name else return undefined
 146                           ; hetmet_pga_comp <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_comp_name else return undefined
 147                           ; hetmet_pga_first <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_first_name else return undefined
 148                           ; hetmet_pga_second <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_second_name else return undefined
 149                           ; hetmet_pga_cancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancell_name else return undefined
 150                           ; hetmet_pga_cancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancelr_name else return undefined
 151                           ; hetmet_pga_uncancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancell_name else return undefined
 152                           ; hetmet_pga_uncancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancelr_name else return undefined
 153                           ; hetmet_pga_assoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_assoc_name else return undefined
 154                           ; hetmet_pga_unassoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_unassoc_name else return undefined
 155                           ; hetmet_pga_copy <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_copy_name else return undefined
 156                           ; hetmet_pga_drop <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_drop_name else return undefined
 157                           ; hetmet_pga_swap <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_swap_name else return undefined
 158                           ; hetmet_pga_applyl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyl_name else return undefined
 159                           ; hetmet_pga_applyr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyr_name else return undefined
 160                           ; hetmet_pga_curryl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryl_name else return undefined
 161                           ; hetmet_pga_curryr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryr_name else return undefined
 162                           ; let hpc_init
 163                                   | opt_Hpc   = hpcInitCode mod ds_hpc_info
 164                                   | otherwise = empty
 165                           ; return ( ds_ev_binds
 166                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
 167                                    , spec_rules ++ ds_rules, ds_vects
 168                                    , ds_fords `appendStubC` hpc_init
 169                                    , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc
 170                                    , hetmet_flatten
 171                                    , hetmet_unflatten
 172                                    , hetmet_flattened_id
 173                                    , hetmet_PGArrow
 174                                    , hetmet_PGArrow_unit
 175                                    , hetmet_PGArrow_tensor
 176                                    , hetmet_PGArrow_exponent
 177                                    , hetmet_pga_id
 178                                    , hetmet_pga_comp
 179                                    , hetmet_pga_first
 180                                    , hetmet_pga_second
 181                                    , hetmet_pga_cancell
 182                                    , hetmet_pga_cancelr
 183                                    , hetmet_pga_uncancell
 184                                    , hetmet_pga_uncancelr
 185                                    , hetmet_pga_assoc
 186                                    , hetmet_pga_unassoc
 187                                    , hetmet_pga_copy
 188                                    , hetmet_pga_drop
 189                                    , hetmet_pga_swap
 190                                    , hetmet_pga_applyl
 191                                    , hetmet_pga_applyr
 192                                    , hetmet_pga_curryl
 193                                    , hetmet_pga_curryr
 194                                    ) }
 195
 196         ; case mb_res of {
 197            Nothing -> return (msgs, Nothing) ;
 198            Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks
 199                                    , hetmet_brak, hetmet_esc
 200                                    , hetmet_flatten
 201                                    , hetmet_unflatten
 202                                    , hetmet_flattened_id
 203                                    , hetmet_PGArrow
 204                                    , hetmet_PGArrow_unit
 205                                    , hetmet_PGArrow_tensor
 206                                    , hetmet_PGArrow_exponent
 207                                    , hetmet_pga_id
 208                                    , hetmet_pga_comp
 209                                    , hetmet_pga_first
 210                                    , hetmet_pga_second
 211                                    , hetmet_pga_cancell
 212                                    , hetmet_pga_cancelr
 213                                    , hetmet_pga_uncancell
 214                                    , hetmet_pga_uncancelr
 215                                    , hetmet_pga_assoc
 216                                    , hetmet_pga_unassoc
 217                                    , hetmet_pga_copy
 218                                    , hetmet_pga_drop
 219                                    , hetmet_pga_swap
 220                                    , hetmet_pga_applyl
 221                                    , hetmet_pga_applyr
 222                                    , hetmet_pga_curryl
 223                                    , hetmet_pga_curryr) -> do
 224
 225         {       -- Add export flags to bindings
 226           keep_alive <- readIORef keep_var
 227         ; let (rules_for_locals, rules_for_imps)
 228                    = partition isLocalRule all_rules
 229               final_prs = addExportFlagsAndRules target
 230                               export_set keep_alive rules_for_locals (fromOL all_prs)
 231
 232               final_pgm = combineEvBinds ds_ev_binds final_prs
 233         -- Notice that we put the whole lot in a big Rec, even the foreign binds
 234         -- When compiling PrelFloat, which defines data Float = F# Float#
 235         -- we want F# to be in scope in the foreign marshalling code!
 236         -- You might think it doesn't matter, but the simplifier brings all top-level
 237         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 238
 239         -- Lint result if necessary, and print
 240         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
 241                (vcat [ pprCoreBindings final_pgm
 242                      , pprRules rules_for_imps ])
 243
 244         ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
 245                          -- The simpleOptPgm gets rid of type
 246                          -- bindings plus any stupid dead code
 247
 248         ; ds_binds' <- if dopt Opt_F_coqpass dflags
 249                        then do { us <- mkSplitUniqSupply '~'
 250                                ; return (coqPassCoreToCore
 251                                              hetmet_brak
 252                                              hetmet_esc
 253                                              hetmet_flatten
 254                                              hetmet_unflatten
 255                                              hetmet_flattened_id
 256                                              us
 257                                              ds_binds
 258                                              hetmet_PGArrow
 259                                              hetmet_PGArrow_unit
 260                                              hetmet_PGArrow_tensor
 261                                              hetmet_PGArrow_exponent
 262                                              hetmet_pga_id
 263                                              hetmet_pga_comp
 264                                              hetmet_pga_first
 265                                              hetmet_pga_second
 266                                              hetmet_pga_cancell
 267                                              hetmet_pga_cancelr
 268                                              hetmet_pga_uncancell
 269                                              hetmet_pga_uncancelr
 270                                              hetmet_pga_assoc
 271                                              hetmet_pga_unassoc
 272                                              hetmet_pga_copy
 273                                              hetmet_pga_drop
 274                                              hetmet_pga_swap
 275                                              hetmet_pga_applyl
 276                                              hetmet_pga_applyr
 277                                              hetmet_pga_curryl
 278                                              hetmet_pga_curryr)
 279                                }
 280                        else return ds_binds
 281
 282         ; dumpIfSet_dyn dflags Opt_D_coqpass "Coq Pass Output" $ text $ coqPassCoreToString ds_binds'
 283
 284         ; dumpIfSet_dyn dflags Opt_D_dump_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
 285
 286         ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
 287
 288         ; let used_names = mkUsedNames tcg_env
 289         ; deps <- mkDependencies tcg_env
 290
 291         ; let mod_guts = ModGuts {
 292                 mg_module       = mod,
 293                 mg_boot         = isHsBoot hsc_src,
 294                 mg_exports      = exports,
 295                 mg_deps         = deps,
 296                 mg_used_names   = used_names,
 297                 mg_dir_imps     = imp_mods imports,
 298                 mg_rdr_env      = rdr_env,
 299                 mg_fix_env      = fix_env,
 300                 mg_warns        = warns,
 301                 mg_anns         = anns,
 302                 mg_types        = type_env,
 303                 mg_insts        = insts,
 304                 mg_fam_insts    = fam_insts,
 305                 mg_inst_env     = inst_env,
 306                 mg_fam_inst_env = fam_inst_env,
 307                 mg_rules        = ds_rules_for_imps,
 308                 mg_binds        = ds_binds',
 309                 mg_foreign      = ds_fords,
 310                 mg_hpc_info     = ds_hpc_info,
 311                 mg_modBreaks    = modBreaks,
 312                 mg_vect_decls   = ds_vects,
 313                 mg_vect_info    = noVectInfo
 314               }
 315         ; return (msgs, Just mod_guts)
 316         }}}
 317
 318 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
 319 dsImpSpecs imp_specs
 320  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
 321       ; let (spec_binds, spec_rules) = unzip spec_prs
 322       ; return (concatOL spec_binds, spec_rules) }
 323
 324 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
 325 -- Top-level bindings can include coercion bindings, but not via superclasses
 326 -- See Note [Top-level evidence]
 327 combineEvBinds [] val_prs
 328   = [Rec val_prs]
 329 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
 330   | isId b    = combineEvBinds bs ((b,r):val_prs)
 331   | otherwise = NonRec b r : combineEvBinds bs val_prs
 332 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
 333   = combineEvBinds bs (prs ++ val_prs)
 334 combineEvBinds (CaseEvBind x _ _ : _) _
 335   = pprPanic "topEvBindPairs" (ppr x)
 336 \end{code}
 337
 338 Note [Top-level evidence]
 339 ~~~~~~~~~~~~~~~~~~~~~~~~~
 340 Top-level evidence bindings may be mutually recursive with the top-level value
 341 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
 342 because the occurrence analyser doesn't teke account of type/coercion variables
 343 when computing dependencies.
 344
 345 So we pull out the type/coercion variables (which are in dependency order),
 346 and Rec the rest.
 347
 348
 349 \begin{code}
 350 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
 351 mkAutoScc dflags mod exports
 352   | not opt_SccProfilingOn      -- No profiling
 353   = NoSccs
 354     -- Add auto-scc on all top-level things
 355   | dopt Opt_AutoSccsOnAllToplevs dflags
 356   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
 357     -- See #1641.  This is pretty yucky, but I can't see a better way
 358     -- to identify compiler-generated Ids, and at least this should
 359     -- catch them all.
 360     -- Only on exported things
 361   | dopt Opt_AutoSccsOnExportedToplevs dflags
 362   = AddSccs mod (\id -> idName id `elemNameSet` exports)
 363   | otherwise
 364   = NoSccs
 365
 366 deSugarExpr :: HscEnv
 367             -> Module -> GlobalRdrEnv -> TypeEnv
 368             -> LHsExpr Id
 369             -> IO (Messages, Maybe CoreExpr)
 370 -- Prints its own errors; returns Nothing if error occurred
 371
 372 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
 373     let dflags = hsc_dflags hsc_env
 374     showPass dflags "Desugar"
 375
 376     -- Do desugaring
 377     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
 378                                    dsLExpr tc_expr
 379
 380     case mb_core_expr of
 381       Nothing   -> return (msgs, Nothing)
 382       Just expr -> do
 383
 384         -- Dump output
 385         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
 386
 387         return (msgs, Just expr)
 388 \end{code}
 389
 390 %************************************************************************
 391 %*                                                                      *
 392 %*              Add rules and export flags to binders
 393 %*                                                                      *
 394 %************************************************************************
 395
 396 \begin{code}
 397 addExportFlagsAndRules
 398     :: HscTarget -> NameSet -> NameSet -> [CoreRule]
 399     -> [(Id, t)] -> [(Id, t)]
 400 addExportFlagsAndRules target exports keep_alive rules prs
 401   = mapFst add_one prs
 402   where
 403     add_one bndr = add_rules name (add_export name bndr)
 404        where
 405          name = idName bndr
 406
 407     ---------- Rules --------
 408         -- See Note [Attach rules to local ids]
 409         -- NB: the binder might have some existing rules,
 410         -- arising from specialisation pragmas
 411     add_rules name bndr
 412         | Just rules <- lookupNameEnv rule_base name
 413         = bndr `addIdSpecialisations` rules
 414         | otherwise
 415         = bndr
 416     rule_base = extendRuleBaseList emptyRuleBase rules
 417
 418     ---------- Export flag --------
 419     -- See Note [Adding export flags]
 420     add_export name bndr
 421         | dont_discard name = setIdExported bndr
 422         | otherwise         = bndr
 423
 424     dont_discard :: Name -> Bool
 425     dont_discard name = is_exported name
 426                      || name `elemNameSet` keep_alive
 427
 428         -- In interactive mode, we don't want to discard any top-level
 429         -- entities at all (eg. do not inline them away during
 430         -- simplification), and retain them all in the TypeEnv so they are
 431         -- available from the command line.
 432         --
 433         -- isExternalName separates the user-defined top-level names from those
 434         -- introduced by the type checker.
 435     is_exported :: Name -> Bool
 436     is_exported | target == HscInterpreted = isExternalName
 437                 | otherwise                = (`elemNameSet` exports)
 438 \end{code}
 439
 440
 441 Note [Adding export flags]
 442 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 443 Set the no-discard flag if either
 444         a) the Id is exported
 445         b) it's mentioned in the RHS of an orphan rule
 446         c) it's in the keep-alive set
 447
 448 It means that the binding won't be discarded EVEN if the binding
 449 ends up being trivial (v = w) -- the simplifier would usually just
 450 substitute w for v throughout, but we don't apply the substitution to
 451 the rules (maybe we should?), so this substitution would make the rule
 452 bogus.
 453
 454 You might wonder why exported Ids aren't already marked as such;
 455 it's just because the type checker is rather busy already and
 456 I didn't want to pass in yet another mapping.
 457
 458 Note [Attach rules to local ids]
 459 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 460 Find the rules for locally-defined Ids; then we can attach them
 461 to the binders in the top-level bindings
 462
 463 Reason
 464   - It makes the rules easier to look up
 465   - It means that transformation rules and specialisations for
 466     locally defined Ids are handled uniformly
 467   - It keeps alive things that are referred to only from a rule
 468     (the occurrence analyser knows about rules attached to Ids)
 469   - It makes sure that, when we apply a rule, the free vars
 470     of the RHS are more likely to be in scope
 471   - The imported rules are carried in the in-scope set
 472     which is extended on each iteration by the new wave of
 473     local binders; any rules which aren't on the binding will
 474     thereby get dropped
 475
 476
 477 %************************************************************************
 478 %*                                                                      *
 479 %*              Desugaring transformation rules
 480 %*                                                                      *
 481 %************************************************************************
 482
 483 \begin{code}
 484 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 485 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
 486   = putSrcSpanDs loc $
 487     do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
 488
 489         ; lhs' <- unsetOptM Opt_EnableRewriteRules $
 490                   unsetOptM Opt_WarnIdentities $
 491                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 492
 493         ; rhs' <- dsLExpr rhs
 494
 495         -- Substitute the dict bindings eagerly,
 496         -- and take the body apart into a (f args) form
 497         ; case decomposeRuleLhs bndrs' lhs' of {
 498                 Left msg -> do { warnDs msg; return Nothing } ;
 499                 Right (final_bndrs, fn_id, args) -> do
 500
 501         { let is_local = isLocalId fn_id
 502                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
 503                 -- we don't want to attach rules to the bindings of implicit Ids,
 504                 -- because they don't show up in the bindings until just before code gen
 505               fn_name   = idName fn_id
 506               final_rhs = simpleOptExpr rhs'    -- De-crap it
 507               rule      = mkRule False {- Not auto -} is_local
 508                                  name act fn_name final_bndrs args final_rhs
 509         ; return (Just rule)
 510         } } }
 511 \end{code}
 512
 513 Note [Desugaring RULE left hand sides]
 514 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 515 For the LHS of a RULE we do *not* want to desugar
 516     [x]   to    build (\cn. x `c` n)
 517 We want to leave explicit lists simply as chains
 518 of cons's. We can achieve that slightly indirectly by
 519 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 520
 521 That keeps the desugaring of list comprehensions simple too.
 522
 523 Nor do we want to warn of conversion identities on the LHS;
 524 the rule is precisly to optimise them:
 525   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
 526
 527
 528 %************************************************************************
 529 %*                                                                      *
 530 %*              Desugaring vectorisation declarations
 531 %*                                                                      *
 532 %************************************************************************
 533
 534 \begin{code}
 535 dsVect :: LVectDecl Id -> DsM CoreVect
 536 dsVect (L loc (HsVect v rhs))
 537   = putSrcSpanDs loc $
 538     do { rhs' <- fmapMaybeM dsLExpr rhs
 539        ; return $ Vect (unLoc v) rhs'
 540            }
 541 -- dsVect (L loc (HsVect v Nothing))
 542 --   = return $ Vect v Nothing
 543 -- dsVect (L loc (HsVect v (Just rhs)))
 544 --   = putSrcSpanDs loc $
 545 --     do { rhs' <- dsLExpr rhs
 546 --        ; return $ Vect v (Just rhs')
 547 --       }
 548 \end{code}