summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Coverage.hs1368
-rw-r--r--compiler/deSugar/Desugar.hs545
-rw-r--r--compiler/deSugar/DsArrows.hs1270
-rw-r--r--compiler/deSugar/DsBinds.hs1325
-rw-r--r--compiler/deSugar/DsBinds.hs-boot6
-rw-r--r--compiler/deSugar/DsCCall.hs381
-rw-r--r--compiler/deSugar/DsExpr.hs1201
-rw-r--r--compiler/deSugar/DsExpr.hs-boot12
-rw-r--r--compiler/deSugar/DsForeign.hs820
-rw-r--r--compiler/deSugar/DsGRHSs.hs155
-rw-r--r--compiler/deSugar/DsListComp.hs676
-rw-r--r--compiler/deSugar/DsMeta.hs2958
-rw-r--r--compiler/deSugar/DsMonad.hs598
-rw-r--r--compiler/deSugar/DsUsage.hs375
-rw-r--r--compiler/deSugar/DsUtils.hs1001
-rw-r--r--compiler/deSugar/ExtractDocs.hs360
-rw-r--r--compiler/deSugar/Match.hs1148
-rw-r--r--compiler/deSugar/Match.hs-boot36
-rw-r--r--compiler/deSugar/MatchCon.hs296
-rw-r--r--compiler/deSugar/MatchLit.hs520
20 files changed, 0 insertions, 15051 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
deleted file mode 100644
index 3e124b5829..0000000000
--- a/compiler/deSugar/Coverage.hs
+++ /dev/null
@@ -1,1368 +0,0 @@
-{-
-(c) Galois, 2006
-(c) University of Glasgow, 2007
--}
-
-{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DeriveFunctor #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-module Coverage (addTicksToBinds, hpcInitCode) where
-
-import GhcPrelude as Prelude
-
-import qualified GHC.Runtime.Interpreter as GHCi
-import GHCi.RemoteTypes
-import Data.Array
-import GHC.ByteCode.Types
-import GHC.Stack.CCS
-import Type
-import GHC.Hs
-import Module
-import Outputable
-import DynFlags
-import ConLike
-import Control.Monad
-import SrcLoc
-import ErrUtils
-import NameSet hiding (FreeVars)
-import Name
-import Bag
-import CostCentre
-import CostCentreState
-import CoreSyn
-import Id
-import VarSet
-import Data.List
-import FastString
-import HscTypes
-import TyCon
-import BasicTypes
-import MonadUtils
-import Maybes
-import GHC.Cmm.CLabel
-import Util
-
-import Data.Time
-import System.Directory
-
-import Trace.Hpc.Mix
-import Trace.Hpc.Util
-
-import qualified Data.ByteString as BS
-import Data.Map (Map)
-import qualified Data.Map as Map
-
-{-
-************************************************************************
-* *
-* The main function: addTicksToBinds
-* *
-************************************************************************
--}
-
-addTicksToBinds
- :: HscEnv
- -> Module
- -> ModLocation -- ... off the current module
- -> NameSet -- Exported Ids. When we call addTicksToBinds,
- -- isExportedId doesn't work yet (the desugarer
- -- hasn't set it), so we have to work from this set.
- -> [TyCon] -- Type constructor in this module
- -> LHsBinds GhcTc
- -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
-
-addTicksToBinds hsc_env mod mod_loc exports tyCons binds
- | let dflags = hsc_dflags hsc_env
- passes = coveragePasses dflags, not (null passes),
- Just orig_file <- ml_hs_file mod_loc,
- not ("boot" `isSuffixOf` orig_file) = do
-
- let orig_file2 = guessSourceFile binds orig_file
-
- tickPass tickish (binds,st) =
- let env = TTE
- { fileName = mkFastString orig_file2
- , declPath = []
- , tte_dflags = dflags
- , exports = exports
- , inlines = emptyVarSet
- , inScope = emptyVarSet
- , blackList = Map.fromList
- [ (getSrcSpan (tyConName tyCon),())
- | tyCon <- tyCons ]
- , density = mkDensity tickish dflags
- , this_mod = mod
- , tickishType = tickish
- }
- (binds',_,st') = unTM (addTickLHsBinds binds) env st
- in (binds', st')
-
- initState = TT { tickBoxCount = 0
- , mixEntries = []
- , ccIndices = newCostCentreState
- }
-
- (binds1,st) = foldr tickPass (binds, initState) passes
-
- let tickCount = tickBoxCount st
- entries = reverse $ mixEntries st
- hashNo <- writeMixEntries dflags mod tickCount entries orig_file2
- modBreaks <- mkModBreaks hsc_env mod tickCount entries
-
- dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell
- (pprLHsBinds binds1)
-
- return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
-
- | otherwise = return (binds, emptyHpcInfo False, Nothing)
-
-guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
-guessSourceFile binds orig_file =
- -- Try look for a file generated from a .hsc file to a
- -- .hs file, by peeking ahead.
- let top_pos = catMaybes $ foldr (\ (L pos _) rest ->
- srcSpanFileName_maybe pos : rest) [] binds
- in
- case top_pos of
- (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
- -> unpackFS file_name
- _ -> orig_file
-
-
-mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
-mkModBreaks hsc_env mod count entries
- | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
- breakArray <- GHCi.newBreakArray hsc_env (length entries)
- ccs <- mkCCSArray hsc_env mod count entries
- let
- locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ]
- varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ]
- declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
- return emptyModBreaks
- { modBreaks_flags = breakArray
- , modBreaks_locs = locsTicks
- , modBreaks_vars = varsTicks
- , modBreaks_decls = declsTicks
- , modBreaks_ccs = ccs
- }
- | otherwise = return emptyModBreaks
-
-mkCCSArray
- :: HscEnv -> Module -> Int -> [MixEntry_]
- -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
-mkCCSArray hsc_env modul count entries = do
- if interpreterProfiled dflags
- then do
- let module_str = moduleNameString (moduleName modul)
- costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)
- return (listArray (0,count-1) costcentres)
- else do
- return (listArray (0,-1) [])
- where
- dflags = hsc_dflags hsc_env
- mk_one (srcspan, decl_path, _, _) = (name, src)
- where name = concat (intersperse "." decl_path)
- src = showSDoc dflags (ppr srcspan)
-
-
-writeMixEntries
- :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
-writeMixEntries dflags mod count entries filename
- | not (gopt Opt_Hpc dflags) = return 0
- | otherwise = do
- let
- hpc_dir = hpcDir dflags
- mod_name = moduleNameString (moduleName mod)
-
- hpc_mod_dir
- | moduleUnitId mod == mainUnitId = hpc_dir
- | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
-
- tabStop = 8 -- <tab> counts as a normal char in GHC's
- -- location ranges.
-
- createDirectoryIfMissing True hpc_mod_dir
- modTime <- getModificationUTCTime filename
- let entries' = [ (hpcPos, box)
- | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
- when (entries' `lengthIsNot` count) $ do
- panic "the number of .mix entries are inconsistent"
- let hashNo = mixHash filename modTime tabStop entries'
- mixCreate hpc_mod_dir mod_name
- $ Mix filename modTime (toHash hashNo) tabStop entries'
- return hashNo
-
-
--- -----------------------------------------------------------------------------
--- TickDensity: where to insert ticks
-
-data TickDensity
- = TickForCoverage -- for Hpc
- | TickForBreakPoints -- for GHCi
- | TickAllFunctions -- for -prof-auto-all
- | TickTopFunctions -- for -prof-auto-top
- | TickExportedFunctions -- for -prof-auto-exported
- | TickCallSites -- for stack tracing
- deriving Eq
-
-mkDensity :: TickishType -> DynFlags -> TickDensity
-mkDensity tickish dflags = case tickish of
- HpcTicks -> TickForCoverage
- SourceNotes -> TickForCoverage
- Breakpoints -> TickForBreakPoints
- ProfNotes ->
- case profAuto dflags of
- ProfAutoAll -> TickAllFunctions
- ProfAutoTop -> TickTopFunctions
- ProfAutoExports -> TickExportedFunctions
- ProfAutoCalls -> TickCallSites
- _other -> panic "mkDensity"
-
--- | Decide whether to add a tick to a binding or not.
-shouldTickBind :: TickDensity
- -> Bool -- top level?
- -> Bool -- exported?
- -> Bool -- simple pat bind?
- -> Bool -- INLINE pragma?
- -> Bool
-
-shouldTickBind density top_lev exported _simple_pat inline
- = case density of
- TickForBreakPoints -> False
- -- we never add breakpoints to simple pattern bindings
- -- (there's always a tick on the rhs anyway).
- TickAllFunctions -> not inline
- TickTopFunctions -> top_lev && not inline
- TickExportedFunctions -> exported && not inline
- TickForCoverage -> True
- TickCallSites -> False
-
-shouldTickPatBind :: TickDensity -> Bool -> Bool
-shouldTickPatBind density top_lev
- = case density of
- TickForBreakPoints -> False
- TickAllFunctions -> True
- TickTopFunctions -> top_lev
- TickExportedFunctions -> False
- TickForCoverage -> False
- TickCallSites -> False
-
--- -----------------------------------------------------------------------------
--- Adding ticks to bindings
-
-addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
-addTickLHsBinds = mapBagM addTickLHsBind
-
-addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
-addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
- abs_exports = abs_exports })) = do
- withEnv add_exports $ do
- withEnv add_inlines $ do
- binds' <- addTickLHsBinds binds
- return $ L pos $ bind { abs_binds = binds' }
- where
- -- in AbsBinds, the Id on each binding is not the actual top-level
- -- Id that we are defining, they are related by the abs_exports
- -- field of AbsBinds. So if we're doing TickExportedFunctions we need
- -- to add the local Ids to the set of exported Names so that we know to
- -- tick the right bindings.
- add_exports env =
- env{ exports = exports env `extendNameSetList`
- [ idName mid
- | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
- , idName pid `elemNameSet` (exports env) ] }
-
- -- See Note [inline sccs]
- add_inlines env =
- env{ inlines = inlines env `extendVarSetList`
- [ mid
- | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
- , isInlinePragma (idInlinePragma pid) ] }
-
-addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
- let name = getOccString id
- decl_path <- getPathEntry
- density <- getDensity
-
- inline_ids <- liftM inlines getEnv
- -- See Note [inline sccs]
- let inline = isInlinePragma (idInlinePragma id)
- || id `elemVarSet` inline_ids
-
- -- See Note [inline sccs]
- tickish <- tickishType `liftM` getEnv
- if inline && tickish == ProfNotes then return (L pos funBind) else do
-
- (fvs, mg) <-
- getFreeVars $
- addPathEntry name $
- addTickMatchGroup False (fun_matches funBind)
-
- case mg of
- MG {} -> return ()
- _ -> panic "addTickLHsBind"
-
- blackListed <- isBlackListed pos
- exported_names <- liftM exports getEnv
-
- -- We don't want to generate code for blacklisted positions
- -- We don't want redundant ticks on simple pattern bindings
- -- We don't want to tick non-exported bindings in TickExportedFunctions
- let simple = isSimplePatBind funBind
- toplev = null decl_path
- exported = idName id `elemNameSet` exported_names
-
- tick <- if not blackListed &&
- shouldTickBind density toplev exported simple inline
- then
- bindTick density name pos fvs
- else
- return Nothing
-
- let mbCons = maybe Prelude.id (:)
- return $ L pos $ funBind { fun_matches = mg
- , fun_tick = tick `mbCons` fun_tick funBind }
-
- where
- -- a binding is a simple pattern binding if it is a funbind with
- -- zero patterns
- isSimplePatBind :: HsBind GhcTc -> Bool
- isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
-
--- TODO: Revisit this
-addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
- , pat_rhs = rhs }))) = do
-
- let simplePatId = isSimplePat lhs
-
- -- TODO: better name for rhs's for non-simple patterns?
- let name = maybe "(...)" getOccString simplePatId
-
- (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
- let pat' = pat { pat_rhs = rhs'}
-
- -- Should create ticks here?
- density <- getDensity
- decl_path <- getPathEntry
- let top_lev = null decl_path
- if not (shouldTickPatBind density top_lev)
- then return (L pos pat')
- else do
-
- let mbCons = maybe id (:)
-
- let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat'
-
- -- Allocate the ticks
-
- rhs_tick <- bindTick density name pos fvs
- let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks
-
- patvar_tickss <- case simplePatId of
- Just{} -> return initial_patvar_tickss
- Nothing -> do
- let patvars = map getOccString (collectPatBinders lhs)
- patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
- return
- (zipWith mbCons patvar_ticks
- (initial_patvar_tickss ++ repeat []))
-
- return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
-
--- Only internal stuff, not from source, uses VarBind, so we ignore it.
-addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
-addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
-addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
-
-bindTick
- :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
-bindTick density name pos fvs = do
- decl_path <- getPathEntry
- let
- toplev = null decl_path
- count_entries = toplev || density == TickAllFunctions
- top_only = density /= TickAllFunctions
- box_label = if toplev then TopLevelBox [name]
- else LocalBox (decl_path ++ [name])
- --
- allocATickBox box_label count_entries top_only pos fvs
-
-
--- Note [inline sccs]
---
--- The reason not to add ticks to INLINE functions is that this is
--- sometimes handy for avoiding adding a tick to a particular function
--- (see #6131)
---
--- So for now we do not add any ticks to INLINE functions at all.
---
--- We used to use isAnyInlinePragma to figure out whether to avoid adding
--- ticks for this purpose. However, #12962 indicates that this contradicts
--- the documentation on profiling (which only mentions INLINE pragmas).
--- So now we're more careful about what we avoid adding ticks to.
-
--- -----------------------------------------------------------------------------
--- Decorate an LHsExpr with ticks
-
--- selectively add ticks to interesting expressions
-addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExpr e@(L pos e0) = do
- d <- getDensity
- case d of
- TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
- TickForCoverage -> tick_it
- TickCallSites | isCallSite e0 -> tick_it
- _other -> dont_tick_it
- where
- tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
- dont_tick_it = addTickLHsExprNever e
-
--- Add a tick to an expression which is the RHS of an equation or a binding.
--- We always consider these to be breakpoints, unless the expression is a 'let'
--- (because the body will definitely have a tick somewhere). ToDo: perhaps
--- we should treat 'case' and 'if' the same way?
-addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprRHS e@(L pos e0) = do
- d <- getDensity
- case d of
- TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
- | otherwise -> tick_it
- TickForCoverage -> tick_it
- TickCallSites | isCallSite e0 -> tick_it
- _other -> dont_tick_it
- where
- tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
- dont_tick_it = addTickLHsExprNever e
-
--- The inner expression of an evaluation context:
--- let binds in [], ( [] )
--- we never tick these if we're doing HPC, but otherwise
--- we treat it like an ordinary expression.
-addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprEvalInner e = do
- d <- getDensity
- case d of
- TickForCoverage -> addTickLHsExprNever e
- _otherwise -> addTickLHsExpr e
-
--- | A let body is treated differently from addTickLHsExprEvalInner
--- above with TickForBreakPoints, because for breakpoints we always
--- want to tick the body, even if it is not a redex. See test
--- break012. This gives the user the opportunity to inspect the
--- values of the let-bound variables.
-addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprLetBody e@(L pos e0) = do
- d <- getDensity
- case d of
- TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
- | otherwise -> tick_it
- _other -> addTickLHsExprEvalInner e
- where
- tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
- dont_tick_it = addTickLHsExprNever e
-
--- version of addTick that does not actually add a tick,
--- because the scope of this tick is completely subsumed by
--- another.
-addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprNever (L pos e0) = do
- e1 <- addTickHsExpr e0
- return $ L pos e1
-
--- general heuristic: expressions which do not denote values are good
--- break points
-isGoodBreakExpr :: HsExpr GhcTc -> Bool
-isGoodBreakExpr (HsApp {}) = True
-isGoodBreakExpr (HsAppType {}) = True
-isGoodBreakExpr (OpApp {}) = True
-isGoodBreakExpr _other = False
-
-isCallSite :: HsExpr GhcTc -> Bool
-isCallSite HsApp{} = True
-isCallSite HsAppType{} = True
-isCallSite OpApp{} = True
-isCallSite _ = False
-
-addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprOptAlt oneOfMany (L pos e0)
- = ifDensity TickForCoverage
- (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
- (addTickLHsExpr (L pos e0))
-
-addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addBinTickLHsExpr boxLabel (L pos e0)
- = ifDensity TickForCoverage
- (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
- (addTickLHsExpr (L pos e0))
-
-
--- -----------------------------------------------------------------------------
--- Decorate the body of an HsExpr with ticks.
--- (Whether to put a tick around the whole expression was already decided,
--- in the addTickLHsExpr family of functions.)
-
-addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
-addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
-addTickHsExpr e@(HsConLikeOut _ con)
- | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
-addTickHsExpr e@(HsIPVar {}) = return e
-addTickHsExpr e@(HsOverLit {}) = return e
-addTickHsExpr e@(HsOverLabel{}) = return e
-addTickHsExpr e@(HsLit {}) = return e
-addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
- (addTickMatchGroup True matchgroup)
-addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x)
- (addTickMatchGroup True mgs)
-addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)
- (addTickLHsExpr e2)
-addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)
- (addTickLHsExprNever e)
- (return ty)
-
-addTickHsExpr (OpApp fix e1 e2 e3) =
- liftM4 OpApp
- (return fix)
- (addTickLHsExpr e1)
- (addTickLHsExprNever e2)
- (addTickLHsExpr e3)
-addTickHsExpr (NegApp x e neg) =
- liftM2 (NegApp x)
- (addTickLHsExpr e)
- (addTickSyntaxExpr hpcSrcSpan neg)
-addTickHsExpr (HsPar x e) =
- liftM (HsPar x) (addTickLHsExprEvalInner e)
-addTickHsExpr (SectionL x e1 e2) =
- liftM2 (SectionL x)
- (addTickLHsExpr e1)
- (addTickLHsExprNever e2)
-addTickHsExpr (SectionR x e1 e2) =
- liftM2 (SectionR x)
- (addTickLHsExprNever e1)
- (addTickLHsExpr e2)
-addTickHsExpr (ExplicitTuple x es boxity) =
- liftM2 (ExplicitTuple x)
- (mapM addTickTupArg es)
- (return boxity)
-addTickHsExpr (ExplicitSum ty tag arity e) = do
- e' <- addTickLHsExpr e
- return (ExplicitSum ty tag arity e')
-addTickHsExpr (HsCase x e mgs) =
- liftM2 (HsCase x)
- (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
- -- be evaluated.
- (addTickMatchGroup False mgs)
-addTickHsExpr (HsIf x cnd e1 e2 e3) =
- liftM3 (HsIf x cnd)
- (addBinTickLHsExpr (BinBox CondBinBox) e1)
- (addTickLHsExprOptAlt True e2)
- (addTickLHsExprOptAlt True e3)
-addTickHsExpr (HsMultiIf ty alts)
- = do { let isOneOfMany = case alts of [_] -> False; _ -> True
- ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
- ; return $ HsMultiIf ty alts' }
-addTickHsExpr (HsLet x (L l binds) e) =
- bindLocals (collectLocalBinders binds) $
- liftM2 (HsLet x . L l)
- (addTickHsLocalBinds binds) -- to think about: !patterns.
- (addTickLHsExprLetBody e)
-addTickHsExpr (HsDo srcloc cxt (L l stmts))
- = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
- ; return (HsDo srcloc cxt (L l stmts')) }
- where
- forQual = case cxt of
- ListComp -> Just $ BinBox QualBinBox
- _ -> Nothing
-addTickHsExpr (ExplicitList ty wit es) =
- liftM3 ExplicitList
- (return ty)
- (addTickWit wit)
- (mapM (addTickLHsExpr) es)
- where addTickWit Nothing = return Nothing
- addTickWit (Just fln)
- = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
- return (Just fln')
-
-addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
-
-addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
- = do { rec_binds' <- addTickHsRecordBinds rec_binds
- ; return (expr { rcon_flds = rec_binds' }) }
-
-addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
- = do { e' <- addTickLHsExpr e
- ; flds' <- mapM addTickHsRecField flds
- ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
-
-addTickHsExpr (ExprWithTySig x e ty) =
- liftM3 ExprWithTySig
- (return x)
- (addTickLHsExprNever e) -- No need to tick the inner expression
- -- for expressions with signatures
- (return ty)
-addTickHsExpr (ArithSeq ty wit arith_seq) =
- liftM3 ArithSeq
- (return ty)
- (addTickWit wit)
- (addTickArithSeqInfo arith_seq)
- where addTickWit Nothing = return Nothing
- addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
- return (Just fl')
-
--- We might encounter existing ticks (multiple Coverage passes)
-addTickHsExpr (HsTick x t e) =
- liftM (HsTick x t) (addTickLHsExprNever e)
-addTickHsExpr (HsBinTick x t0 t1 e) =
- liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
-
-addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do
- e2 <- allocTickBox (ExpBox False) False False pos $
- addTickHsExpr e0
- return $ unLoc e2
-addTickHsExpr (HsPragE x p e) =
- liftM (HsPragE x p) (addTickLHsExpr e)
-addTickHsExpr e@(HsBracket {}) = return e
-addTickHsExpr e@(HsTcBracketOut {}) = return e
-addTickHsExpr e@(HsRnBracketOut {}) = return e
-addTickHsExpr e@(HsSpliceE {}) = return e
-addTickHsExpr (HsProc x pat cmdtop) =
- liftM2 (HsProc x)
- (addTickLPat pat)
- (liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (XExpr (HsWrap w e)) =
- liftM XExpr $
- liftM (HsWrap w)
- (addTickHsExpr e) -- Explicitly no tick on inside
-
--- Others should never happen in expression content.
-addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
-
-addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
-addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e
- ; return (L l (Present x e')) }
-addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
-addTickTupArg (L _ (XTupArg nec)) = noExtCon nec
-
-
-addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
- -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
-addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
- let isOneOfMany = matchesOneOfMany matches
- matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
- return $ mg { mg_alts = L l matches' }
-addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec
-
-addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
- -> TM (Match GhcTc (LHsExpr GhcTc))
-addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
- , m_grhss = gRHSs }) =
- bindLocals (collectPatsBinders pats) $ do
- gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
- return $ match { m_grhss = gRHSs' }
-addTickMatch _ _ (XMatch nec) = noExtCon nec
-
-addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
- -> TM (GRHSs GhcTc (LHsExpr GhcTc))
-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do
- bindLocals binders $ do
- local_binds' <- addTickHsLocalBinds local_binds
- guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
- return $ GRHSs x guarded' (L l local_binds')
- where
- binders = collectLocalBinders local_binds
-addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec
-
-addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
- -> TM (GRHS GhcTc (LHsExpr GhcTc))
-addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
- (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
- (addTickGRHSBody isOneOfMany isLambda expr)
- return $ GRHS x stmts' expr'
-addTickGRHS _ _ (XGRHS nec) = noExtCon nec
-
-addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
- d <- getDensity
- case d of
- TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr
- TickAllFunctions | isLambda ->
- addPathEntry "\\" $
- allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
- addTickHsExpr e0
- _otherwise ->
- addTickLHsExprRHS expr
-
-addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
- -> TM [ExprLStmt GhcTc]
-addTickLStmts isGuard stmts = do
- (stmts, _) <- addTickLStmts' isGuard stmts (return ())
- return stmts
-
-addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
- -> TM ([ExprLStmt GhcTc], a)
-addTickLStmts' isGuard lstmts res
- = bindLocals (collectLStmtsBinders lstmts) $
- do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
- ; a <- res
- ; return (lstmts', a) }
-
-addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
- -> TM (Stmt GhcTc (LHsExpr GhcTc))
-addTickStmt _isGuard (LastStmt x e noret ret) = do
- liftM3 (LastStmt x)
- (addTickLHsExpr e)
- (pure noret)
- (addTickSyntaxExpr hpcSrcSpan ret)
-addTickStmt _isGuard (BindStmt x pat e bind fail) = do
- liftM4 (BindStmt x)
- (addTickLPat pat)
- (addTickLHsExprRHS e)
- (addTickSyntaxExpr hpcSrcSpan bind)
- (addTickSyntaxExpr hpcSrcSpan fail)
-addTickStmt isGuard (BodyStmt x e bind' guard') = do
- liftM3 (BodyStmt x)
- (addTick isGuard e)
- (addTickSyntaxExpr hpcSrcSpan bind')
- (addTickSyntaxExpr hpcSrcSpan guard')
-addTickStmt _isGuard (LetStmt x (L l binds)) = do
- liftM (LetStmt x . L l)
- (addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
- liftM3 (ParStmt x)
- (mapM (addTickStmtAndBinders isGuard) pairs)
- (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
- (addTickSyntaxExpr hpcSrcSpan bindExpr)
-addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
- args' <- mapM (addTickApplicativeArg isGuard) args
- return (ApplicativeStmt body_ty args' mb_join)
-
-addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
- , trS_by = by, trS_using = using
- , trS_ret = returnExpr, trS_bind = bindExpr
- , trS_fmap = liftMExpr }) = do
- t_s <- addTickLStmts isGuard stmts
- t_y <- fmapMaybeM addTickLHsExprRHS by
- t_u <- addTickLHsExprRHS using
- t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
- t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
- t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr))
- return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
- , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
-
-addTickStmt isGuard stmt@(RecStmt {})
- = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
- ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
- ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
- ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
- ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
- , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-
-addTickStmt _ (XStmtLR nec) = noExtCon nec
-
-addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
- | otherwise = addTickLHsExprRHS e
-
-addTickApplicativeArg
- :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
- -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-addTickApplicativeArg isGuard (op, arg) =
- liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
- where
- addTickArg (ApplicativeArgOne x pat expr isBody fail) =
- (ApplicativeArgOne x)
- <$> addTickLPat pat
- <*> addTickLHsExpr expr
- <*> pure isBody
- <*> addTickSyntaxExpr hpcSrcSpan fail
- addTickArg (ApplicativeArgMany x stmts ret pat) =
- (ApplicativeArgMany x)
- <$> addTickLStmts isGuard stmts
- <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
- <*> addTickLPat pat
- addTickArg (XApplicativeArg nec) = noExtCon nec
-
-addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
- -> TM (ParStmtBlock GhcTc GhcTc)
-addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
- liftM3 (ParStmtBlock x)
- (addTickLStmts isGuard stmts)
- (return ids)
- (addTickSyntaxExpr hpcSrcSpan returnExpr)
-addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec
-
-addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
-addTickHsLocalBinds (HsValBinds x binds) =
- liftM (HsValBinds x)
- (addTickHsValBinds binds)
-addTickHsLocalBinds (HsIPBinds x binds) =
- liftM (HsIPBinds x)
- (addTickHsIPBinds binds)
-addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x)
-addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x)
-
-addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
- -> TM (HsValBindsLR GhcTc (GhcPass b))
-addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
- b <- liftM2 NValBinds
- (mapM (\ (rec,binds') ->
- liftM2 (,)
- (return rec)
- (addTickLHsBinds binds'))
- binds)
- (return sigs)
- return $ XValBindsLR b
-addTickHsValBinds _ = panic "addTickHsValBinds"
-
-addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
-addTickHsIPBinds (IPBinds dictbinds ipbinds) =
- liftM2 IPBinds
- (return dictbinds)
- (mapM (liftL (addTickIPBind)) ipbinds)
-addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
-
-addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
-addTickIPBind (IPBind x nm e) =
- liftM2 (IPBind x)
- (return nm)
- (addTickLHsExpr e)
-addTickIPBind (XIPBind x) = return (XIPBind x)
-
--- There is no location here, so we might need to use a context location??
-addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
-addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do
- x' <- fmap unLoc (addTickLHsExpr (L pos x))
- return $ syn { syn_expr = x' }
-addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc
-
--- we do not walk into patterns.
-addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
-addTickLPat pat = return pat
-
-addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
-addTickHsCmdTop (HsCmdTop x cmd) =
- liftM2 HsCmdTop
- (return x)
- (addTickLHsCmd cmd)
-addTickHsCmdTop (XCmdTop nec) = noExtCon nec
-
-addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
-addTickLHsCmd (L pos c0) = do
- c1 <- addTickHsCmd c0
- return $ L pos c1
-
-addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
-addTickHsCmd (HsCmdLam x matchgroup) =
- liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
-addTickHsCmd (HsCmdApp x c e) =
- liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
-{-
-addTickHsCmd (OpApp e1 c2 fix c3) =
- liftM4 OpApp
- (addTickLHsExpr e1)
- (addTickLHsCmd c2)
- (return fix)
- (addTickLHsCmd c3)
--}
-addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
-addTickHsCmd (HsCmdCase x e mgs) =
- liftM2 (HsCmdCase x)
- (addTickLHsExpr e)
- (addTickCmdMatchGroup mgs)
-addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
- liftM3 (HsCmdIf x cnd)
- (addBinTickLHsExpr (BinBox CondBinBox) e1)
- (addTickLHsCmd c2)
- (addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet x (L l binds) c) =
- bindLocals (collectLocalBinders binds) $
- liftM2 (HsCmdLet x . L l)
- (addTickHsLocalBinds binds) -- to think about: !patterns.
- (addTickLHsCmd c)
-addTickHsCmd (HsCmdDo srcloc (L l stmts))
- = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
- ; return (HsCmdDo srcloc (L l stmts')) }
-
-addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) =
- liftM5 HsCmdArrApp
- (return arr_ty)
- (addTickLHsExpr e1)
- (addTickLHsExpr e2)
- (return ty1)
- (return lr)
-addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
- liftM4 (HsCmdArrForm x)
- (addTickLHsExpr e)
- (return f)
- (return fix)
- (mapM (liftL (addTickHsCmdTop)) cmdtop)
-
-addTickHsCmd (XCmd (HsWrap w cmd)) =
- liftM XCmd $
- liftM (HsWrap w) (addTickHsCmd cmd)
-
--- Others should never happen in a command context.
---addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
-
-addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
- -> TM (MatchGroup GhcTc (LHsCmd GhcTc))
-addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
- matches' <- mapM (liftL addTickCmdMatch) matches
- return $ mg { mg_alts = L l matches' }
-addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec
-
-addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
-addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
- bindLocals (collectPatsBinders pats) $ do
- gRHSs' <- addTickCmdGRHSs gRHSs
- return $ match { m_grhss = gRHSs' }
-addTickCmdMatch (XMatch nec) = noExtCon nec
-
-addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
-addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do
- bindLocals binders $ do
- local_binds' <- addTickHsLocalBinds local_binds
- guarded' <- mapM (liftL addTickCmdGRHS) guarded
- return $ GRHSs x guarded' (L l local_binds')
- where
- binders = collectLocalBinders local_binds
-addTickCmdGRHSs (XGRHSs nec) = noExtCon nec
-
-addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
--- The *guards* are *not* Cmds, although the body is
--- C.f. addTickGRHS for the BinBox stuff
-addTickCmdGRHS (GRHS x stmts cmd)
- = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
- stmts (addTickLHsCmd cmd)
- ; return $ GRHS x stmts' expr' }
-addTickCmdGRHS (XGRHS nec) = noExtCon nec
-
-addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
- -> TM [LStmt GhcTc (LHsCmd GhcTc)]
-addTickLCmdStmts stmts = do
- (stmts, _) <- addTickLCmdStmts' stmts (return ())
- return stmts
-
-addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
- -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
-addTickLCmdStmts' lstmts res
- = bindLocals binders $ do
- lstmts' <- mapM (liftL addTickCmdStmt) lstmts
- a <- res
- return (lstmts', a)
- where
- binders = collectLStmtsBinders lstmts
-
-addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
-addTickCmdStmt (BindStmt x pat c bind fail) = do
- liftM4 (BindStmt x)
- (addTickLPat pat)
- (addTickLHsCmd c)
- (return bind)
- (return fail)
-addTickCmdStmt (LastStmt x c noret ret) = do
- liftM3 (LastStmt x)
- (addTickLHsCmd c)
- (pure noret)
- (addTickSyntaxExpr hpcSrcSpan ret)
-addTickCmdStmt (BodyStmt x c bind' guard') = do
- liftM3 (BodyStmt x)
- (addTickLHsCmd c)
- (addTickSyntaxExpr hpcSrcSpan bind')
- (addTickSyntaxExpr hpcSrcSpan guard')
-addTickCmdStmt (LetStmt x (L l binds)) = do
- liftM (LetStmt x . L l)
- (addTickHsLocalBinds binds)
-addTickCmdStmt stmt@(RecStmt {})
- = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
- ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
- ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
- ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
- ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
- , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-addTickCmdStmt ApplicativeStmt{} =
- panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
-addTickCmdStmt (XStmtLR nec) =
- noExtCon nec
-
--- Others should never happen in a command context.
-addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)
-
-addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
-addTickHsRecordBinds (HsRecFields fields dd)
- = do { fields' <- mapM addTickHsRecField fields
- ; return (HsRecFields fields' dd) }
-
-addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)
- -> TM (LHsRecField' id (LHsExpr GhcTc))
-addTickHsRecField (L l (HsRecField id expr pun))
- = do { expr' <- addTickLHsExpr expr
- ; return (L l (HsRecField id expr' pun)) }
-
-
-addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
-addTickArithSeqInfo (From e1) =
- liftM From
- (addTickLHsExpr e1)
-addTickArithSeqInfo (FromThen e1 e2) =
- liftM2 FromThen
- (addTickLHsExpr e1)
- (addTickLHsExpr e2)
-addTickArithSeqInfo (FromTo e1 e2) =
- liftM2 FromTo
- (addTickLHsExpr e1)
- (addTickLHsExpr e2)
-addTickArithSeqInfo (FromThenTo e1 e2 e3) =
- liftM3 FromThenTo
- (addTickLHsExpr e1)
- (addTickLHsExpr e2)
- (addTickLHsExpr e3)
-
-data TickTransState = TT { tickBoxCount:: Int
- , mixEntries :: [MixEntry_]
- , ccIndices :: CostCentreState
- }
-
-data TickTransEnv = TTE { fileName :: FastString
- , density :: TickDensity
- , tte_dflags :: DynFlags
- , exports :: NameSet
- , inlines :: VarSet
- , declPath :: [String]
- , inScope :: VarSet
- , blackList :: Map SrcSpan ()
- , this_mod :: Module
- , tickishType :: TickishType
- }
-
--- deriving Show
-
-data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
- deriving (Eq)
-
-coveragePasses :: DynFlags -> [TickishType]
-coveragePasses dflags =
- ifa (hscTarget dflags == HscInterpreted) Breakpoints $
- ifa (gopt Opt_Hpc dflags) HpcTicks $
- ifa (gopt Opt_SccProfilingOn dflags &&
- profAuto dflags /= NoProfAuto) ProfNotes $
- ifa (debugLevel dflags > 0) SourceNotes []
- where ifa f x xs | f = x:xs
- | otherwise = xs
-
--- | Tickishs that only make sense when their source code location
--- refers to the current file. This might not always be true due to
--- LINE pragmas in the code - which would confuse at least HPC.
-tickSameFileOnly :: TickishType -> Bool
-tickSameFileOnly HpcTicks = True
-tickSameFileOnly _other = False
-
-type FreeVars = OccEnv Id
-noFVs :: FreeVars
-noFVs = emptyOccEnv
-
--- Note [freevars]
--- For breakpoints we want to collect the free variables of an
--- expression for pinning on the HsTick. We don't want to collect
--- *all* free variables though: in particular there's no point pinning
--- on free variables that are will otherwise be in scope at the GHCi
--- prompt, which means all top-level bindings. Unfortunately detecting
--- top-level bindings isn't easy (collectHsBindsBinders on the top-level
--- bindings doesn't do it), so we keep track of a set of "in-scope"
--- variables in addition to the free variables, and the former is used
--- to filter additions to the latter. This gives us complete control
--- over what free variables we track.
-
-newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
- deriving (Functor)
- -- a combination of a state monad (TickTransState) and a writer
- -- monad (FreeVars).
-
-instance Applicative TM where
- pure a = TM $ \ _env st -> (a,noFVs,st)
- (<*>) = ap
-
-instance Monad TM where
- (TM m) >>= k = TM $ \ env st ->
- case m env st of
- (r1,fv1,st1) ->
- case unTM (k r1) env st1 of
- (r2,fv2,st2) ->
- (r2, fv1 `plusOccEnv` fv2, st2)
-
-instance HasDynFlags TM where
- getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)
-
--- | Get the next HPC cost centre index for a given centre name
-getCCIndexM :: FastString -> TM CostCentreIndex
-getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $
- ccIndices st
- in (idx, noFVs, st { ccIndices = is' })
-
-getState :: TM TickTransState
-getState = TM $ \ _ st -> (st, noFVs, st)
-
-setState :: (TickTransState -> TickTransState) -> TM ()
-setState f = TM $ \ _ st -> ((), noFVs, f st)
-
-getEnv :: TM TickTransEnv
-getEnv = TM $ \ env st -> (env, noFVs, st)
-
-withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
-withEnv f (TM m) = TM $ \ env st ->
- case m (f env) st of
- (a, fvs, st') -> (a, fvs, st')
-
-getDensity :: TM TickDensity
-getDensity = TM $ \env st -> (density env, noFVs, st)
-
-ifDensity :: TickDensity -> TM a -> TM a -> TM a
-ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
-
-getFreeVars :: TM a -> TM (FreeVars, a)
-getFreeVars (TM m)
- = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
-
-freeVar :: Id -> TM ()
-freeVar id = TM $ \ env st ->
- if id `elemVarSet` inScope env
- then ((), unitOccEnv (nameOccName (idName id)) id, st)
- else ((), noFVs, st)
-
-addPathEntry :: String -> TM a -> TM a
-addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
-
-getPathEntry :: TM [String]
-getPathEntry = declPath `liftM` getEnv
-
-getFileName :: TM FastString
-getFileName = fileName `liftM` getEnv
-
-isGoodSrcSpan' :: SrcSpan -> Bool
-isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
-isGoodSrcSpan' (UnhelpfulSpan _) = False
-
-isGoodTickSrcSpan :: SrcSpan -> TM Bool
-isGoodTickSrcSpan pos = do
- file_name <- getFileName
- tickish <- tickishType `liftM` getEnv
- let need_same_file = tickSameFileOnly tickish
- same_file = Just file_name == srcSpanFileName_maybe pos
- return (isGoodSrcSpan' pos && (not need_same_file || same_file))
-
-ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
-ifGoodTickSrcSpan pos then_code else_code = do
- good <- isGoodTickSrcSpan pos
- if good then then_code else else_code
-
-bindLocals :: [Id] -> TM a -> TM a
-bindLocals new_ids (TM m)
- = TM $ \ env st ->
- case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
- (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
- where occs = [ nameOccName (idName id) | id <- new_ids ]
-
-isBlackListed :: SrcSpan -> TM Bool
-isBlackListed pos = TM $ \ env st ->
- case Map.lookup pos (blackList env) of
- Nothing -> (False,noFVs,st)
- Just () -> (True,noFVs,st)
-
--- the tick application inherits the source position of its
--- expression argument to support nested box allocations
-allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)
- -> TM (LHsExpr GhcTc)
-allocTickBox boxLabel countEntries topOnly pos m =
- ifGoodTickSrcSpan pos (do
- (fvs, e) <- getFreeVars m
- env <- getEnv
- tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
- return (L pos (HsTick noExtField tickish (L pos e)))
- ) (do
- e <- m
- return (L pos e)
- )
-
--- the tick application inherits the source position of its
--- expression argument to support nested box allocations
-allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
- -> TM (Maybe (Tickish Id))
-allocATickBox boxLabel countEntries topOnly pos fvs =
- ifGoodTickSrcSpan pos (do
- let
- mydecl_path = case boxLabel of
- TopLevelBox x -> x
- LocalBox xs -> xs
- _ -> panic "allocATickBox"
- tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
- return (Just tickish)
- ) (return Nothing)
-
-
-mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
- -> TM (Tickish Id)
-mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
-
- let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs
- -- unlifted types cause two problems here:
- -- * we can't bind them at the GHCi prompt
- -- (bindLocalsAtBreakpoint already filters them out),
- -- * the simplifier might try to substitute a literal for
- -- the Id, and we can't handle that.
-
- me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)
-
- cc_name | topOnly = head decl_path
- | otherwise = concat (intersperse "." decl_path)
-
- dflags <- getDynFlags
- env <- getEnv
- case tickishType env of
- HpcTicks -> do
- c <- liftM tickBoxCount getState
- setState $ \st -> st { tickBoxCount = c + 1
- , mixEntries = me : mixEntries st }
- return $ HpcTick (this_mod env) c
-
- ProfNotes -> do
- let nm = mkFastString cc_name
- flavour <- HpcCC <$> getCCIndexM nm
- let cc = mkUserCC nm (this_mod env) pos flavour
- count = countEntries && gopt Opt_ProfCountEntries dflags
- return $ ProfNote cc count True{-scopes-}
-
- Breakpoints -> do
- c <- liftM tickBoxCount getState
- setState $ \st -> st { tickBoxCount = c + 1
- , mixEntries = me:mixEntries st }
- return $ Breakpoint c ids
-
- SourceNotes | RealSrcSpan pos' <- pos ->
- return $ SourceNote pos' cc_name
-
- _otherwise -> panic "mkTickish: bad source span!"
-
-
-allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)
- -> TM (LHsExpr GhcTc)
-allocBinTickBox boxLabel pos m = do
- env <- getEnv
- case tickishType env of
- HpcTicks -> do e <- liftM (L pos) m
- ifGoodTickSrcSpan pos
- (mkBinTickBoxHpc boxLabel pos e)
- (return e)
- _other -> allocTickBox (ExpBox False) False False pos m
-
-mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
- -> TM (LHsExpr GhcTc)
-mkBinTickBoxHpc boxLabel pos e =
- TM $ \ env st ->
- let meT = (pos,declPath env, [],boxLabel True)
- meF = (pos,declPath env, [],boxLabel False)
- meE = (pos,declPath env, [],ExpBox False)
- c = tickBoxCount st
- mes = mixEntries st
- in
- ( L pos $ HsTick noExtField (HpcTick (this_mod env) c)
- $ L pos $ HsBinTick noExtField (c+1) (c+2) e
- -- notice that F and T are reversed,
- -- because we are building the list in
- -- reverse...
- , noFVs
- , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
- )
-
-mkHpcPos :: SrcSpan -> HpcPos
-mkHpcPos pos@(RealSrcSpan s)
- | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
- srcSpanStartCol s,
- srcSpanEndLine s,
- srcSpanEndCol s - 1)
- -- the end column of a SrcSpan is one
- -- greater than the last column of the
- -- span (see SrcLoc), whereas HPC
- -- expects to the column range to be
- -- inclusive, hence we subtract one above.
-mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
-
-hpcSrcSpan :: SrcSpan
-hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
-
-matchesOneOfMany :: [LMatch GhcTc body] -> Bool
-matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
- where
- matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))
- = length grhss
- matchCount (L _ (Match { m_grhss = XGRHSs nec }))
- = noExtCon nec
- matchCount (L _ (XMatch nec)) = noExtCon nec
-
-type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
-
--- For the hash value, we hash everything: the file name,
--- the timestamp of the original source file, the tab stop,
--- and the mix entries. We cheat, and hash the show'd string.
--- This hash only has to be hashed at Mix creation time,
--- and is for sanity checking only.
-
-mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
-mixHash file tm tabstop entries = fromIntegral $ hashString
- (show $ Mix file tm 0 tabstop entries)
-
-{-
-************************************************************************
-* *
-* initialisation
-* *
-************************************************************************
-
-Each module compiled with -fhpc declares an initialisation function of
-the form `hpc_init_<module>()`, which is emitted into the _stub.c file
-and annotated with __attribute__((constructor)) so that it gets
-executed at startup time.
-
-The function's purpose is to call hs_hpc_module to register this
-module with the RTS, and it looks something like this:
-
-static void hpc_init_Main(void) __attribute__((constructor));
-static void hpc_init_Main(void)
-{extern StgWord64 _hpc_tickboxes_Main_hpc[];
- hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
--}
-
-hpcInitCode :: Module -> HpcInfo -> SDoc
-hpcInitCode _ (NoHpcInfo {}) = Outputable.empty
-hpcInitCode this_mod (HpcInfo tickCount hashNo)
- = vcat
- [ text "static void hpc_init_" <> ppr this_mod
- <> text "(void) __attribute__((constructor));"
- , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
- , braces (vcat [
- text "extern StgWord64 " <> tickboxes <>
- text "[]" <> semi,
- text "hs_hpc_module" <>
- parens (hcat (punctuate comma [
- doubleQuotes full_name_str,
- int tickCount, -- really StgWord32
- int hashNo, -- really StgWord32
- tickboxes
- ])) <> semi
- ])
- ]
- where
- tickboxes = ppr (mkHpcTicksLabel $ this_mod)
-
- module_name = hcat (map (text.charToC) $ BS.unpack $
- bytesFS (moduleNameFS (Module.moduleName this_mod)))
- package_name = hcat (map (text.charToC) $ BS.unpack $
- bytesFS (unitIdFS (moduleUnitId this_mod)))
- full_name_str
- | moduleUnitId this_mod == mainUnitId
- = module_name
- | otherwise
- = package_name <> char '/' <> module_name
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
deleted file mode 100644
index bbf67cfc48..0000000000
--- a/compiler/deSugar/Desugar.hs
+++ /dev/null
@@ -1,545 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-The Desugarer: turning HsSyn into Core.
--}
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-module Desugar (
- -- * Desugaring operations
- deSugar, deSugarExpr
- ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import DsUsage
-import DynFlags
-import HscTypes
-import GHC.Hs
-import TcRnTypes
-import TcRnMonad ( finalSafeMode, fixSafeInstances )
-import TcRnDriver ( runTcInteractive )
-import Id
-import Name
-import Type
-import Avail
-import CoreSyn
-import CoreFVs ( exprsSomeFreeVarsList )
-import CoreOpt ( simpleOptPgm, simpleOptExpr )
-import PprCore
-import DsMonad
-import DsExpr
-import DsBinds
-import DsForeign
-import PrelNames ( coercibleTyConKey )
-import TysPrim ( eqReprPrimTyCon )
-import Unique ( hasKey )
-import Coercion ( mkCoVarCo )
-import TysWiredIn ( coercibleDataCon )
-import DataCon ( dataConWrapId )
-import MkCore ( mkCoreLet )
-import Module
-import NameSet
-import NameEnv
-import Rules
-import BasicTypes ( Activation(.. ), competesWith, pprRuleName )
-import CoreMonad ( CoreToDo(..) )
-import CoreLint ( endPassIO )
-import VarSet
-import FastString
-import ErrUtils
-import Outputable
-import SrcLoc
-import Coverage
-import Util
-import MonadUtils
-import OrdList
-import ExtractDocs
-
-import Data.List
-import Data.IORef
-import Control.Monad( when )
-import Plugins ( LoadedPlugin(..) )
-
-{-
-************************************************************************
-* *
-* The main function: deSugar
-* *
-************************************************************************
--}
-
--- | Main entry point to the desugarer.
-deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
--- Can modify PCS by faulting in more declarations
-
-deSugar hsc_env
- mod_loc
- tcg_env@(TcGblEnv { tcg_mod = id_mod,
- tcg_semantic_mod = mod,
- tcg_src = hsc_src,
- tcg_type_env = type_env,
- tcg_imports = imports,
- tcg_exports = exports,
- tcg_keep = keep_var,
- tcg_th_splice_used = tc_splice_used,
- tcg_rdr_env = rdr_env,
- tcg_fix_env = fix_env,
- tcg_inst_env = inst_env,
- tcg_fam_inst_env = fam_inst_env,
- tcg_merged = merged,
- tcg_warns = warns,
- tcg_anns = anns,
- tcg_binds = binds,
- tcg_imp_specs = imp_specs,
- tcg_dependent_files = dependent_files,
- tcg_ev_binds = ev_binds,
- tcg_th_foreign_files = th_foreign_files_var,
- tcg_fords = fords,
- tcg_rules = rules,
- tcg_patsyns = patsyns,
- tcg_tcs = tcs,
- tcg_insts = insts,
- tcg_fam_insts = fam_insts,
- tcg_hpc = other_hpc_info,
- tcg_complete_matches = complete_matches
- })
-
- = do { let dflags = hsc_dflags hsc_env
- print_unqual = mkPrintUnqualified dflags rdr_env
- ; withTiming dflags
- (text "Desugar"<+>brackets (ppr mod))
- (const ()) $
- do { -- Desugar the program
- ; let export_set = availsToNameSet exports
- target = hscTarget dflags
- hpcInfo = emptyHpcInfo other_hpc_info
-
- ; (binds_cvr, ds_hpc_info, modBreaks)
- <- if not (isHsBootOrSig hsc_src)
- then addTicksToBinds hsc_env mod mod_loc
- export_set (typeEnvTyCons type_env) binds
- else return (binds, hpcInfo, Nothing)
- ; (msgs, mb_res) <- initDs hsc_env tcg_env $
- do { ds_ev_binds <- dsEvBinds ev_binds
- ; core_prs <- dsTopLHsBinds binds_cvr
- ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
- ; (ds_fords, foreign_prs) <- dsForeigns fords
- ; ds_rules <- mapMaybeM dsRule rules
- ; let hpc_init
- | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
- | otherwise = empty
- ; return ( ds_ev_binds
- , foreign_prs `appOL` core_prs `appOL` spec_prs
- , spec_rules ++ ds_rules
- , ds_fords `appendStubC` hpc_init) }
-
- ; case mb_res of {
- Nothing -> return (msgs, Nothing) ;
- Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->
-
- do { -- Add export flags to bindings
- keep_alive <- readIORef keep_var
- ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
- final_prs = addExportFlagsAndRules target export_set keep_alive
- rules_for_locals (fromOL all_prs)
-
- final_pgm = combineEvBinds ds_ev_binds final_prs
- -- Notice that we put the whole lot in a big Rec, even the foreign binds
- -- When compiling PrelFloat, which defines data Float = F# Float#
- -- we want F# to be in scope in the foreign marshalling code!
- -- You might think it doesn't matter, but the simplifier brings all top-level
- -- things into the in-scope set before simplifying; so we get no unfolding for F#!
-
- ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
- ; (ds_binds, ds_rules_for_imps)
- <- simpleOptPgm dflags mod final_pgm rules_for_imps
- -- The simpleOptPgm gets rid of type
- -- bindings plus any stupid dead code
-
- ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
-
- ; let used_names = mkUsedNames tcg_env
- pluginModules =
- map lpModule (cachedPlugins (hsc_dflags hsc_env))
- ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env))
- (map mi_module pluginModules) tcg_env
-
- ; used_th <- readIORef tc_splice_used
- ; dep_files <- readIORef dependent_files
- ; safe_mode <- finalSafeMode dflags tcg_env
- ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names
- dep_files merged pluginModules
- -- id_mod /= mod when we are processing an hsig, but hsigs
- -- never desugared and compiled (there's no code!)
- -- Consequently, this should hold for any ModGuts that make
- -- past desugaring. See Note [Identity versus semantic module].
- ; MASSERT( id_mod == mod )
-
- ; foreign_files <- readIORef th_foreign_files_var
-
- ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env
-
- ; let mod_guts = ModGuts {
- mg_module = mod,
- mg_hsc_src = hsc_src,
- mg_loc = mkFileSrcSpan mod_loc,
- mg_exports = exports,
- mg_usages = usages,
- mg_deps = deps,
- mg_used_th = used_th,
- mg_rdr_env = rdr_env,
- mg_fix_env = fix_env,
- mg_warns = warns,
- mg_anns = anns,
- mg_tcs = tcs,
- mg_insts = fixSafeInstances safe_mode insts,
- mg_fam_insts = fam_insts,
- mg_inst_env = inst_env,
- mg_fam_inst_env = fam_inst_env,
- mg_patsyns = patsyns,
- mg_rules = ds_rules_for_imps,
- mg_binds = ds_binds,
- mg_foreign = ds_fords,
- mg_foreign_files = foreign_files,
- mg_hpc_info = ds_hpc_info,
- mg_modBreaks = modBreaks,
- mg_safe_haskell = safe_mode,
- mg_trust_pkg = imp_trust_own_pkg imports,
- mg_complete_sigs = complete_matches,
- mg_doc_hdr = doc_hdr,
- mg_decl_docs = decl_docs,
- mg_arg_docs = arg_docs
- }
- ; return (msgs, Just mod_guts)
- }}}}
-
-mkFileSrcSpan :: ModLocation -> SrcSpan
-mkFileSrcSpan mod_loc
- = case ml_hs_file mod_loc of
- Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
- Nothing -> interactiveSrcSpan -- Presumably
-
-dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
-dsImpSpecs imp_specs
- = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
- ; let (spec_binds, spec_rules) = unzip spec_prs
- ; return (concatOL spec_binds, spec_rules) }
-
-combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
--- Top-level bindings can include coercion bindings, but not via superclasses
--- See Note [Top-level evidence]
-combineEvBinds [] val_prs
- = [Rec val_prs]
-combineEvBinds (NonRec b r : bs) val_prs
- | isId b = combineEvBinds bs ((b,r):val_prs)
- | otherwise = NonRec b r : combineEvBinds bs val_prs
-combineEvBinds (Rec prs : bs) val_prs
- = combineEvBinds bs (prs ++ val_prs)
-
-{-
-Note [Top-level evidence]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Top-level evidence bindings may be mutually recursive with the top-level value
-bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
-because the occurrence analyser doesn't take account of type/coercion variables
-when computing dependencies.
-
-So we pull out the type/coercion variables (which are in dependency order),
-and Rec the rest.
--}
-
-deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)
-
-deSugarExpr hsc_env tc_expr = do {
- let dflags = hsc_dflags hsc_env
-
- ; showPass dflags "Desugar"
-
- -- Do desugaring
- ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $
- dsLExpr tc_expr
-
- ; case mb_core_expr of
- Nothing -> return ()
- Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"
- FormatCore (pprCoreExpr expr)
-
- ; return (msgs, mb_core_expr) }
-
-{-
-************************************************************************
-* *
-* Add rules and export flags to binders
-* *
-************************************************************************
--}
-
-addExportFlagsAndRules
- :: HscTarget -> NameSet -> NameSet -> [CoreRule]
- -> [(Id, t)] -> [(Id, t)]
-addExportFlagsAndRules target exports keep_alive rules prs
- = mapFst add_one prs
- where
- add_one bndr = add_rules name (add_export name bndr)
- where
- name = idName bndr
-
- ---------- Rules --------
- -- See Note [Attach rules to local ids]
- -- NB: the binder might have some existing rules,
- -- arising from specialisation pragmas
- add_rules name bndr
- | Just rules <- lookupNameEnv rule_base name
- = bndr `addIdSpecialisations` rules
- | otherwise
- = bndr
- rule_base = extendRuleBaseList emptyRuleBase rules
-
- ---------- Export flag --------
- -- See Note [Adding export flags]
- add_export name bndr
- | dont_discard name = setIdExported bndr
- | otherwise = bndr
-
- dont_discard :: Name -> Bool
- dont_discard name = is_exported name
- || name `elemNameSet` keep_alive
-
- -- In interactive mode, we don't want to discard any top-level
- -- entities at all (eg. do not inline them away during
- -- simplification), and retain them all in the TypeEnv so they are
- -- available from the command line.
- --
- -- isExternalName separates the user-defined top-level names from those
- -- introduced by the type checker.
- is_exported :: Name -> Bool
- is_exported | targetRetainsAllBindings target = isExternalName
- | otherwise = (`elemNameSet` exports)
-
-{-
-Note [Adding export flags]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Set the no-discard flag if either
- a) the Id is exported
- b) it's mentioned in the RHS of an orphan rule
- c) it's in the keep-alive set
-
-It means that the binding won't be discarded EVEN if the binding
-ends up being trivial (v = w) -- the simplifier would usually just
-substitute w for v throughout, but we don't apply the substitution to
-the rules (maybe we should?), so this substitution would make the rule
-bogus.
-
-You might wonder why exported Ids aren't already marked as such;
-it's just because the type checker is rather busy already and
-I didn't want to pass in yet another mapping.
-
-Note [Attach rules to local ids]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Find the rules for locally-defined Ids; then we can attach them
-to the binders in the top-level bindings
-
-Reason
- - It makes the rules easier to look up
- - It means that transformation rules and specialisations for
- locally defined Ids are handled uniformly
- - It keeps alive things that are referred to only from a rule
- (the occurrence analyser knows about rules attached to Ids)
- - It makes sure that, when we apply a rule, the free vars
- of the RHS are more likely to be in scope
- - The imported rules are carried in the in-scope set
- which is extended on each iteration by the new wave of
- local binders; any rules which aren't on the binding will
- thereby get dropped
-
-
-************************************************************************
-* *
-* Desugaring transformation rules
-* *
-************************************************************************
--}
-
-dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
-dsRule (L loc (HsRule { rd_name = name
- , rd_act = rule_act
- , rd_tmvs = vars
- , rd_lhs = lhs
- , rd_rhs = rhs }))
- = putSrcSpanDs loc $
- do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
-
- ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
- unsetWOptM Opt_WarnIdentities $
- dsLExpr lhs -- Note [Desugaring RULE left hand sides]
-
- ; rhs' <- dsLExpr rhs
- ; this_mod <- getModule
-
- ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
-
- -- Substitute the dict bindings eagerly,
- -- and take the body apart into a (f args) form
- ; dflags <- getDynFlags
- ; case decomposeRuleLhs dflags bndrs'' lhs'' of {
- Left msg -> do { warnDs NoReason msg; return Nothing } ;
- Right (final_bndrs, fn_id, args) -> do
-
- { let is_local = isLocalId fn_id
- -- NB: isLocalId is False of implicit Ids. This is good because
- -- we don't want to attach rules to the bindings of implicit Ids,
- -- because they don't show up in the bindings until just before code gen
- fn_name = idName fn_id
- final_rhs = simpleOptExpr dflags rhs'' -- De-crap it
- rule_name = snd (unLoc name)
- final_bndrs_set = mkVarSet final_bndrs
- arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
- exprsSomeFreeVarsList isId args
-
- ; rule <- dsMkUserRule this_mod is_local
- rule_name rule_act fn_name final_bndrs args
- final_rhs
- ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
- warnRuleShadowing rule_name rule_act fn_id arg_ids
-
- ; return (Just rule)
- } } }
-dsRule (L _ (XRuleDecl nec)) = noExtCon nec
-
-warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
--- See Note [Rules and inlining/other rules]
-warnRuleShadowing rule_name rule_act fn_id arg_ids
- = do { check False fn_id -- We often have multiple rules for the same Id in a
- -- module. Maybe we should check that they don't overlap
- -- but currently we don't
- ; mapM_ (check True) arg_ids }
- where
- check check_rules_too lhs_id
- | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
- -- If imported with no unfolding, no worries
- , idInlineActivation lhs_id `competesWith` rule_act
- = warnDs (Reason Opt_WarnInlineRuleShadowing)
- (vcat [ hang (text "Rule" <+> pprRuleName rule_name
- <+> text "may never fire")
- 2 (text "because" <+> quotes (ppr lhs_id)
- <+> text "might inline first")
- , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"
- <+> quotes (ppr lhs_id)
- , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
-
- | check_rules_too
- , bad_rule : _ <- get_bad_rules lhs_id
- = warnDs (Reason Opt_WarnInlineRuleShadowing)
- (vcat [ hang (text "Rule" <+> pprRuleName rule_name
- <+> text "may never fire")
- 2 (text "because rule" <+> pprRuleName (ruleName bad_rule)
- <+> text "for"<+> quotes (ppr lhs_id)
- <+> text "might fire first")
- , text "Probable fix: add phase [n] or [~n] to the competing rule"
- , whenPprDebug (ppr bad_rule) ])
-
- | otherwise
- = return ()
-
- get_bad_rules lhs_id
- = [ rule | rule <- idCoreRules lhs_id
- , ruleActivation rule `competesWith` rule_act ]
-
--- See Note [Desugaring coerce as cast]
-unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
-unfold_coerce bndrs lhs rhs = do
- (bndrs', wrap) <- go bndrs
- return (bndrs', wrap lhs, wrap rhs)
- where
- go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
- go [] = return ([], id)
- go (v:vs)
- | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)
- , tc `hasKey` coercibleTyConKey = do
- u <- newUnique
-
- let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]
- v' = mkLocalCoVar
- (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'
- box = Var (dataConWrapId coercibleDataCon) `mkTyApps`
- [k, t1, t2] `App`
- Coercion (mkCoVarCo v')
-
- (bndrs, wrap) <- go vs
- return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
- | otherwise = do
- (bndrs,wrap) <- go vs
- return (v:bndrs, wrap)
-
-{- Note [Desugaring RULE left hand sides]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For the LHS of a RULE we do *not* want to desugar
- [x] to build (\cn. x `c` n)
-We want to leave explicit lists simply as chains
-of cons's. We can achieve that slightly indirectly by
-switching off EnableRewriteRules. See DsExpr.dsExplicitList.
-
-That keeps the desugaring of list comprehensions simple too.
-
-Nor do we want to warn of conversion identities on the LHS;
-the rule is precisely to optimise them:
- {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
-
-Note [Desugaring coerce as cast]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want the user to express a rule saying roughly “mapping a coercion over a
-list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
-be written in Haskell. So we use `coerce` for that (#2110). The user writes
- map coerce = coerce
-as a RULE, and this optimizes any kind of mapped' casts away, including `map
-MkNewtype`.
-
-For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
-corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
-`let c = MkCoercible co in ...`. This is later simplified to the desired form
-by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
-See also Note [Getting the map/coerce RULE to work] in CoreSubst.
-
-Note [Rules and inlining/other rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If you have
- f x = ...
- g x = ...
- {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
-then there's a good chance that in a potential rule redex
- ...f (g e)...
-then 'f' or 'g' will inline before the rule can fire. Solution: add an
-INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.
-
-Note that this applies to all the free variables on the LHS, both the
-main function and things in its arguments.
-
-We also check if there are Ids on the LHS that have competing RULES.
-In the above example, suppose we had
- {-# RULES "rule-for-g" forally. g [y] = ... #-}
-Then "rule-for-f" and "rule-for-g" would compete. Better to add phase
-control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
-active; or perhaps after "rule-for-g" has become inactive. This is checked
-by 'competesWith'
-
-Class methods have a built-in RULE to select the method from the dictionary,
-so you can't change the phase on this. That makes id very dubious to
-match on class methods in RULE lhs's. See #10595. I'm not happy
-about this. For example in Control.Arrow we have
-
-{-# RULES "compose/arr" forall f g .
- (arr f) . (arr g) = arr (f . g) #-}
-
-and similar, which will elicit exactly these warnings, and risk never
-firing. But it's not clear what to do instead. We could make the
-class method rules inactive in phase 2, but that would delay when
-subsequent transformations could fire.
--}
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
deleted file mode 100644
index 8c1e161dc9..0000000000
--- a/compiler/deSugar/DsArrows.hs
+++ /dev/null
@@ -1,1270 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Desugaring arrow commands
--}
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-module DsArrows ( dsProcExpr ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import Match
-import DsUtils
-import DsMonad
-
-import GHC.Hs hiding (collectPatBinders, collectPatsBinders,
- collectLStmtsBinders, collectLStmtBinders,
- collectStmtBinders )
-import TcHsSyn
-import qualified GHC.Hs.Utils as HsUtils
-
--- NB: The desugarer, which straddles the source and Core worlds, sometimes
--- needs to see source types (newtypes etc), and sometimes not
--- So WATCH OUT; check each use of split*Ty functions.
--- Sigh. This is a pain.
-
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds,
- dsSyntaxExpr )
-
-import TcType
-import Type ( splitPiTy )
-import TcEvidence
-import CoreSyn
-import CoreFVs
-import CoreUtils
-import MkCore
-import DsBinds (dsHsWrapper)
-
-import Id
-import ConLike
-import TysWiredIn
-import BasicTypes
-import PrelNames
-import Outputable
-import VarSet
-import SrcLoc
-import ListSetOps( assocMaybe )
-import Data.List
-import Util
-import UniqDSet
-
-data DsCmdEnv = DsCmdEnv {
- arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
- }
-
-mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv)
--- See Note [CmdSyntaxTable] in GHC.Hs.Expr
-mkCmdEnv tc_meths
- = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
-
- -- NB: Some of these lookups might fail, but that's OK if the
- -- symbol is never used. That's why we use Maybe first and then
- -- panic. An eager panic caused trouble in typecheck/should_compile/tc192
- ; let the_arr_id = assocMaybe prs arrAName
- the_compose_id = assocMaybe prs composeAName
- the_first_id = assocMaybe prs firstAName
- the_app_id = assocMaybe prs appAName
- the_choice_id = assocMaybe prs choiceAName
- the_loop_id = assocMaybe prs loopAName
-
- -- used as an argument in, e.g., do_premap
- ; check_lev_poly 3 the_arr_id
-
- -- used as an argument in, e.g., dsCmdStmt/BodyStmt
- ; check_lev_poly 5 the_compose_id
-
- -- used as an argument in, e.g., dsCmdStmt/BodyStmt
- ; check_lev_poly 4 the_first_id
-
- -- the result of the_app_id is used as an argument in, e.g.,
- -- dsCmd/HsCmdArrApp/HsHigherOrderApp
- ; check_lev_poly 2 the_app_id
-
- -- used as an argument in, e.g., HsCmdIf
- ; check_lev_poly 5 the_choice_id
-
- -- used as an argument in, e.g., RecStmt
- ; check_lev_poly 4 the_loop_id
-
- ; return (meth_binds, DsCmdEnv {
- arr_id = Var (unmaybe the_arr_id arrAName),
- compose_id = Var (unmaybe the_compose_id composeAName),
- first_id = Var (unmaybe the_first_id firstAName),
- app_id = Var (unmaybe the_app_id appAName),
- choice_id = Var (unmaybe the_choice_id choiceAName),
- loop_id = Var (unmaybe the_loop_id loopAName)
- }) }
- where
- mk_bind (std_name, expr)
- = do { rhs <- dsExpr expr
- ; id <- newSysLocalDs (exprType rhs)
- -- no check needed; these are functions
- ; return (NonRec id rhs, (std_name, id)) }
-
- unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)
- unmaybe (Just id) _ = id
-
- -- returns the result type of a pi-type (that is, a forall or a function)
- -- Note that this result type may be ill-scoped.
- res_type :: Type -> Type
- res_type ty = res_ty
- where
- (_, res_ty) = splitPiTy ty
-
- check_lev_poly :: Int -- arity
- -> Maybe Id -> DsM ()
- check_lev_poly _ Nothing = return ()
- check_lev_poly arity (Just id)
- = dsNoLevPoly (nTimes arity res_type (idType id))
- (text "In the result of the function" <+> quotes (ppr id))
-
-
--- arr :: forall b c. (b -> c) -> a b c
-do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
-do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
-
--- (>>>) :: forall b c d. a b c -> a c d -> a b d
-do_compose :: DsCmdEnv -> Type -> Type -> Type ->
- CoreExpr -> CoreExpr -> CoreExpr
-do_compose ids b_ty c_ty d_ty f g
- = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
-
--- first :: forall b c d. a b c -> a (b,d) (c,d)
-do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
-do_first ids b_ty c_ty d_ty f
- = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
-
--- app :: forall b c. a (a b c, b) c
-do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
-do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
-
--- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
--- note the swapping of d and c
-do_choice :: DsCmdEnv -> Type -> Type -> Type ->
- CoreExpr -> CoreExpr -> CoreExpr
-do_choice ids b_ty c_ty d_ty f g
- = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
-
--- loop :: forall b d c. a (b,d) (c,d) -> a b c
--- note the swapping of d and c
-do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
-do_loop ids b_ty c_ty d_ty f
- = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
-
--- premap :: forall b c d. (b -> c) -> a c d -> a b d
--- premap f g = arr f >>> g
-do_premap :: DsCmdEnv -> Type -> Type -> Type ->
- CoreExpr -> CoreExpr -> CoreExpr
-do_premap ids b_ty c_ty d_ty f g
- = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
-
-mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr
-mkFailExpr ctxt ty
- = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
-
--- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a
-mkFstExpr :: Type -> Type -> DsM CoreExpr
-mkFstExpr a_ty b_ty = do
- a_var <- newSysLocalDs a_ty
- b_var <- newSysLocalDs b_ty
- pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
- return (Lam pair_var
- (coreCasePair pair_var a_var b_var (Var a_var)))
-
--- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
-mkSndExpr :: Type -> Type -> DsM CoreExpr
-mkSndExpr a_ty b_ty = do
- a_var <- newSysLocalDs a_ty
- b_var <- newSysLocalDs b_ty
- pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
- return (Lam pair_var
- (coreCasePair pair_var a_var b_var (Var b_var)))
-
-{-
-Build case analysis of a tuple. This cannot be done in the DsM monad,
-because the list of variables is typically not yet defined.
--}
-
--- coreCaseTuple [u1..] v [x1..xn] body
--- = case v of v { (x1, .., xn) -> body }
--- But the matching may be nested if the tuple is very big
-
-coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
-coreCaseTuple uniqs scrut_var vars body
- = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
-
-coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
-coreCasePair scrut_var var1 var2 body
- = Case (Var scrut_var) scrut_var (exprType body)
- [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)]
-
-mkCorePairTy :: Type -> Type -> Type
-mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
-
-mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
-mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
-
-mkCoreUnitExpr :: CoreExpr
-mkCoreUnitExpr = mkCoreTup []
-
-{-
-The input is divided into a local environment, which is a flat tuple
-(unless it's too big), and a stack, which is a right-nested pair.
-In general, the input has the form
-
- ((x1,...,xn), (s1,...(sk,())...))
-
-where xi are the environment values, and si the ones on the stack,
-with s1 being the "top", the first one to be matched with a lambda.
--}
-
-envStackType :: [Id] -> Type -> Type
-envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty
-
--- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)
-splitTypeAt :: Int -> Type -> ([Type], Type)
-splitTypeAt n ty
- | n == 0 = ([], ty)
- | otherwise = case tcTyConAppArgs ty of
- [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)
- _ -> pprPanic "splitTypeAt" (ppr ty)
-
-----------------------------------------------
--- buildEnvStack
---
--- ((x1,...,xn),stk)
-
-buildEnvStack :: [Id] -> Id -> CoreExpr
-buildEnvStack env_ids stack_id
- = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)
-
-----------------------------------------------
--- matchEnvStack
---
--- \ ((x1,...,xn),stk) -> body
--- =>
--- \ pair ->
--- case pair of (tup,stk) ->
--- case tup of (x1,...,xn) ->
--- body
-
-matchEnvStack :: [Id] -- x1..xn
- -> Id -- stk
- -> CoreExpr -- e
- -> DsM CoreExpr
-matchEnvStack env_ids stack_id body = do
- uniqs <- newUniqueSupply
- tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
- let match_env = coreCaseTuple uniqs tup_var env_ids body
- pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))
- return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
-
-----------------------------------------------
--- matchEnv
---
--- \ (x1,...,xn) -> body
--- =>
--- \ tup ->
--- case tup of (x1,...,xn) ->
--- body
-
-matchEnv :: [Id] -- x1..xn
- -> CoreExpr -- e
- -> DsM CoreExpr
-matchEnv env_ids body = do
- uniqs <- newUniqueSupply
- tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
- return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))
-
-----------------------------------------------
--- matchVarStack
---
--- case (x1, ...(xn, s)...) -> e
--- =>
--- case z0 of (x1,z1) ->
--- case zn-1 of (xn,s) ->
--- e
-matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
-matchVarStack [] stack_id body = return (stack_id, body)
-matchVarStack (param_id:param_ids) stack_id body = do
- (tail_id, tail_code) <- matchVarStack param_ids stack_id body
- pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))
- return (pair_id, coreCasePair pair_id param_id tail_id tail_code)
-
-mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc
-mkHsEnvStackExpr env_ids stack_id
- = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]
-
--- Translation of arrow abstraction
-
--- D; xs |-a c : () --> t' ---> c'
--- --------------------------
--- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c'
---
--- where (xs) is the tuple of variables bound by p
-
-dsProcExpr
- :: LPat GhcTc
- -> LHsCmdTop GhcTc
- -> DsM CoreExpr
-dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
- (meth_binds, meth_ids) <- mkCmdEnv ids
- let locals = mkVarSet (collectPatBinders pat)
- (core_cmd, _free_vars, env_ids)
- <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
- let env_ty = mkBigCoreVarTupTy env_ids
- let env_stk_ty = mkCorePairTy env_ty unitTy
- let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr
- fail_expr <- mkFailExpr ProcExpr env_stk_ty
- var <- selectSimpleMatchVarL pat
- match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr
- let pat_ty = hsLPatType pat
- let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
- (Lam var match_code)
- core_cmd
- return (mkLets meth_binds proc_code)
-dsProcExpr _ _ = panic "dsProcExpr"
-
-{-
-Translation of a command judgement of the form
-
- D; xs |-a c : stk --> t
-
-to an expression e such that
-
- D |- e :: a (xs, stk) t
--}
-
-dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id]
- -> DsM (CoreExpr, DIdSet)
-dsLCmd ids local_vars stk_ty res_ty cmd env_ids
- = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids
-
-dsCmd :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this command
- -> Type -- type of the stack (right-nested tuple)
- -> Type -- return type of the command
- -> HsCmd GhcTc -- command to desugar
- -> [Id] -- list of vars in the input to this command
- -- This is typically fed back,
- -- so don't pull on it too early
- -> DsM (CoreExpr, -- desugared expression
- DIdSet) -- subset of local vars that occur free
-
--- D |- fun :: a t1 t2
--- D, xs |- arg :: t1
--- -----------------------------
--- D; xs |-a fun -< arg : stk --> t2
---
--- ---> premap (\ ((xs), _stk) -> arg) fun
-
-dsCmd ids local_vars stack_ty res_ty
- (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
- env_ids = do
- let
- (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
- (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
- core_arrow <- dsLExprNoLP arrow
- core_arg <- dsLExpr arg
- stack_id <- newSysLocalDs stack_ty
- core_make_arg <- matchEnvStack env_ids stack_id core_arg
- return (do_premap ids
- (envStackType env_ids stack_ty)
- arg_ty
- res_ty
- core_make_arg
- core_arrow,
- exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)
-
--- D, xs |- fun :: a t1 t2
--- D, xs |- arg :: t1
--- ------------------------------
--- D; xs |-a fun -<< arg : stk --> t2
---
--- ---> premap (\ ((xs), _stk) -> (fun, arg)) app
-
-dsCmd ids local_vars stack_ty res_ty
- (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
- env_ids = do
- let
- (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
- (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
-
- core_arrow <- dsLExpr arrow
- core_arg <- dsLExpr arg
- stack_id <- newSysLocalDs stack_ty
- core_make_pair <- matchEnvStack env_ids stack_id
- (mkCorePairExpr core_arrow core_arg)
-
- return (do_premap ids
- (envStackType env_ids stack_ty)
- (mkCorePairTy arrow_ty arg_ty)
- res_ty
- core_make_pair
- (do_app ids arg_ty res_ty),
- (exprsFreeIdsDSet [core_arrow, core_arg])
- `uniqDSetIntersectUniqSet` local_vars)
-
--- D; ys |-a cmd : (t,stk) --> t'
--- D, xs |- exp :: t
--- ------------------------
--- D; xs |-a cmd exp : stk --> t'
---
--- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
-
-dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
- core_arg <- dsLExpr arg
- let
- arg_ty = exprType core_arg
- stack_ty' = mkCorePairTy arg_ty stack_ty
- (core_cmd, free_vars, env_ids')
- <- dsfixCmd ids local_vars stack_ty' res_ty cmd
- stack_id <- newSysLocalDs stack_ty
- arg_id <- newSysLocalDsNoLP arg_ty
- -- push the argument expression onto the stack
- let
- stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
- core_body = bindNonRec arg_id core_arg
- (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
-
- -- match the environment and stack against the input
- core_map <- matchEnvStack env_ids stack_id core_body
- return (do_premap ids
- (envStackType env_ids stack_ty)
- (envStackType env_ids' stack_ty')
- res_ty
- core_map
- core_cmd,
- free_vars `unionDVarSet`
- (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars))
-
--- D; ys |-a cmd : stk t'
--- -----------------------------------------------
--- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'
---
--- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
-
-dsCmd ids local_vars stack_ty res_ty
- (HsCmdLam _ (MG { mg_alts
- = (L _ [L _ (Match { m_pats = pats
- , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) }))
- env_ids = do
- let pat_vars = mkVarSet (collectPatsBinders pats)
- let
- local_vars' = pat_vars `unionVarSet` local_vars
- (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
- (core_body, free_vars, env_ids')
- <- dsfixCmd ids local_vars' stack_ty' res_ty body
- param_ids <- mapM newSysLocalDsNoLP pat_tys
- stack_id' <- newSysLocalDs stack_ty'
-
- -- the expression is built from the inside out, so the actions
- -- are presented in reverse order
-
- let
- -- build a new environment, plus what's left of the stack
- core_expr = buildEnvStack env_ids' stack_id'
- in_ty = envStackType env_ids stack_ty
- in_ty' = envStackType env_ids' stack_ty'
-
- fail_expr <- mkFailExpr LambdaExpr in_ty'
- -- match the patterns against the parameters
- match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr
- fail_expr
- -- match the parameters against the top of the old stack
- (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
- -- match the old environment and stack against the input
- select_code <- matchEnvStack env_ids stack_id param_code
- return (do_premap ids in_ty in_ty' res_ty select_code core_body,
- free_vars `uniqDSetMinusUniqSet` pat_vars)
-
-dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids
- = dsLCmd ids local_vars stack_ty res_ty cmd env_ids
-
--- D, xs |- e :: Bool
--- D; xs1 |-a c1 : stk --> t
--- D; xs2 |-a c2 : stk --> t
--- ----------------------------------------
--- D; xs |-a if e then c1 else c2 : stk --> t
---
--- ---> premap (\ ((xs),stk) ->
--- if e then Left ((xs1),stk) else Right ((xs2),stk))
--- (c1 ||| c2)
-
-dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
- env_ids = do
- core_cond <- dsLExpr cond
- (core_then, fvs_then, then_ids)
- <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
- (core_else, fvs_else, else_ids)
- <- dsfixCmd ids local_vars stack_ty res_ty else_cmd
- stack_id <- newSysLocalDs stack_ty
- either_con <- dsLookupTyCon eitherTyConName
- left_con <- dsLookupDataCon leftDataConName
- right_con <- dsLookupDataCon rightDataConName
-
- let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1,Type ty2, e]
- mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e]
-
- in_ty = envStackType env_ids stack_ty
- then_ty = envStackType then_ids stack_ty
- else_ty = envStackType else_ids stack_ty
- sum_ty = mkTyConApp either_con [then_ty, else_ty]
- fvs_cond = exprFreeIdsDSet core_cond
- `uniqDSetIntersectUniqSet` local_vars
-
- core_left = mk_left_expr then_ty else_ty
- (buildEnvStack then_ids stack_id)
- core_right = mk_right_expr then_ty else_ty
- (buildEnvStack else_ids stack_id)
-
- core_if <- case mb_fun of
- NoSyntaxExprTc -> matchEnvStack env_ids stack_id $
- mkIfThenElse core_cond core_left core_right
- _ -> do { fun_apps <- dsSyntaxExpr mb_fun
- [core_cond, core_left, core_right]
- ; matchEnvStack env_ids stack_id fun_apps }
-
- return (do_premap ids in_ty sum_ty res_ty
- core_if
- (do_choice ids then_ty else_ty res_ty core_then core_else),
- fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)
-
-{-
-Case commands are treated in much the same way as if commands
-(see above) except that there are more alternatives. For example
-
- case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
-
-is translated to
-
- premap (\ ((xs)*ts) -> case e of
- p1 -> (Left (Left (xs1)*ts))
- p2 -> Left ((Right (xs2)*ts))
- p3 -> Right ((xs3)*ts))
- ((c1 ||| c2) ||| c3)
-
-The idea is to extract the commands from the case, build a balanced tree
-of choices, and replace the commands with expressions that build tagged
-tuples, obtaining a case expression that can be desugared normally.
-To build all this, we use triples describing segments of the list of
-case bodies, containing the following fields:
- * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
- into the case replacing the commands
- * a sum type that is the common type of these expressions, and also the
- input type of the arrow
- * a CoreExpr for an arrow built by combining the translated command
- bodies with |||.
--}
-
-dsCmd ids local_vars stack_ty res_ty
- (HsCmdCase _ exp (MG { mg_alts = L l matches
- , mg_ext = MatchGroupTc arg_tys _
- , mg_origin = origin }))
- env_ids = do
- stack_id <- newSysLocalDs stack_ty
-
- -- Extract and desugar the leaf commands in the case, building tuple
- -- expressions that will (after tagging) replace these leaves
-
- let
- leaves = concatMap leavesMatch matches
- make_branch (leaf, bound_vars) = do
- (core_leaf, _fvs, leaf_ids)
- <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty
- res_ty leaf
- return ([mkHsEnvStackExpr leaf_ids stack_id],
- envStackType leaf_ids stack_ty,
- core_leaf)
-
- branches <- mapM make_branch leaves
- either_con <- dsLookupTyCon eitherTyConName
- left_con <- dsLookupDataCon leftDataConName
- right_con <- dsLookupDataCon rightDataConName
- let
- left_id = HsConLikeOut noExtField (RealDataCon left_con)
- right_id = HsConLikeOut noExtField (RealDataCon right_con)
- left_expr ty1 ty2 e = noLoc $ HsApp noExtField
- (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
- right_expr ty1 ty2 e = noLoc $ HsApp noExtField
- (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
-
- -- Prefix each tuple with a distinct series of Left's and Right's,
- -- in a balanced way, keeping track of the types.
-
- merge_branches (builds1, in_ty1, core_exp1)
- (builds2, in_ty2, core_exp2)
- = (map (left_expr in_ty1 in_ty2) builds1 ++
- map (right_expr in_ty1 in_ty2) builds2,
- mkTyConApp either_con [in_ty1, in_ty2],
- do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
- (leaves', sum_ty, core_choices) = foldb merge_branches branches
-
- -- Replace the commands in the case with these tagged tuples,
- -- yielding a HsExpr Id we can feed to dsExpr.
-
- (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
- in_ty = envStackType env_ids stack_ty
-
- core_body <- dsExpr (HsCase noExtField exp
- (MG { mg_alts = L l matches'
- , mg_ext = MatchGroupTc arg_tys sum_ty
- , mg_origin = origin }))
- -- Note that we replace the HsCase result type by sum_ty,
- -- which is the type of matches'
-
- core_matches <- matchEnvStack env_ids stack_id core_body
- return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
- exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)
-
--- D; ys |-a cmd : stk --> t
--- ----------------------------------
--- D; xs |-a let binds in cmd : stk --> t
---
--- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
-
-dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
- env_ids = do
- let
- defined_vars = mkVarSet (collectLocalBinders binds)
- local_vars' = defined_vars `unionVarSet` local_vars
-
- (core_body, _free_vars, env_ids')
- <- dsfixCmd ids local_vars' stack_ty res_ty body
- stack_id <- newSysLocalDs stack_ty
- -- build a new environment, plus the stack, using the let bindings
- core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
- -- match the old environment and stack against the input
- core_map <- matchEnvStack env_ids stack_id core_binds
- return (do_premap ids
- (envStackType env_ids stack_ty)
- (envStackType env_ids' stack_ty)
- res_ty
- core_map
- core_body,
- exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
-
--- D; xs |-a ss : t
--- ----------------------------------
--- D; xs |-a do { ss } : () --> t
---
--- ---> premap (\ (env,stk) -> env) c
-
-dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty
- (L loc stmts))
- env_ids = do
- putSrcSpanDs loc $
- dsNoLevPoly stmts_ty
- (text "In the do-command:" <+> ppr do_block)
- (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
- let env_ty = mkBigCoreVarTupTy env_ids
- core_fst <- mkFstExpr env_ty stack_ty
- return (do_premap ids
- (mkCorePairTy env_ty stack_ty)
- env_ty
- res_ty
- core_fst
- core_stmts,
- env_ids')
-
--- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
--- D; xs |-a ci :: stki --> ti
--- -----------------------------------
--- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
-
-dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
- let env_ty = mkBigCoreVarTupTy env_ids
- core_op <- dsLExpr op
- (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
- return (mkApps (App core_op (Type env_ty)) core_args,
- unionDVarSets fv_sets)
-
-dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do
- (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
- core_wrap <- dsHsWrapper wrap
- return (core_wrap core_cmd, env_ids')
-
-dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
-
--- D; ys |-a c : stk --> t (ys <= xs)
--- ---------------------
--- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c
-
-dsTrimCmdArg
- :: IdSet -- set of local vars available to this command
- -> [Id] -- list of vars in the input to this command
- -> LHsCmdTop GhcTc -- command argument to desugar
- -> DsM (CoreExpr, -- desugared expression
- DIdSet) -- subset of local vars that occur free
-dsTrimCmdArg local_vars env_ids
- (L _ (HsCmdTop
- (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
- (meth_binds, meth_ids) <- mkCmdEnv ids
- (core_cmd, free_vars, env_ids')
- <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
- stack_id <- newSysLocalDs stack_ty
- trim_code
- <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
- let
- in_ty = envStackType env_ids stack_ty
- in_ty' = envStackType env_ids' stack_ty
- arg_code = if env_ids' == env_ids then core_cmd else
- do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
- return (mkLets meth_binds arg_code, free_vars)
-dsTrimCmdArg _ _ _ = panic "dsTrimCmdArg"
-
--- Given D; xs |-a c : stk --> t, builds c with xs fed back.
--- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
-
-dsfixCmd
- :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this command
- -> Type -- type of the stack (right-nested tuple)
- -> Type -- return type of the command
- -> LHsCmd GhcTc -- command to desugar
- -> DsM (CoreExpr, -- desugared expression
- DIdSet, -- subset of local vars that occur free
- [Id]) -- the same local vars as a list, fed back
-dsfixCmd ids local_vars stk_ty cmd_ty cmd
- = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty
- (text "When desugaring the command:" <+> ppr cmd)
- ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }
-
--- Feed back the list of local variables actually used a command,
--- for use as the input tuple of the generated arrow.
-
-trimInput
- :: ([Id] -> DsM (CoreExpr, DIdSet))
- -> DsM (CoreExpr, -- desugared expression
- DIdSet, -- subset of local vars that occur free
- [Id]) -- same local vars as a list, fed back to
- -- the inner function to form the tuple of
- -- inputs to the arrow.
-trimInput build_arrow
- = fixDs (\ ~(_,_,env_ids) -> do
- (core_cmd, free_vars) <- build_arrow env_ids
- return (core_cmd, free_vars, dVarSetElems free_vars))
-
-{-
-Translation of command judgements of the form
-
- D |-a do { ss } : t
--}
-
-dsCmdDo :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this statement
- -> Type -- return type of the statement
- -> [CmdLStmt GhcTc] -- statements to desugar
- -> [Id] -- list of vars in the input to this statement
- -- This is typically fed back,
- -- so don't pull on it too early
- -> DsM (CoreExpr, -- desugared expression
- DIdSet) -- subset of local vars that occur free
-
-dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
-
--- D; xs |-a c : () --> t
--- --------------------------
--- D; xs |-a do { c } : t
---
--- ---> premap (\ (xs) -> ((xs), ())) c
-
-dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do
- putSrcSpanDs loc $ dsNoLevPoly res_ty
- (text "In the command:" <+> ppr body)
- (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
- let env_ty = mkBigCoreVarTupTy env_ids
- env_var <- newSysLocalDs env_ty
- let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
- return (do_premap ids
- env_ty
- (mkCorePairTy env_ty unitTy)
- res_ty
- core_map
- core_body,
- env_ids')
-
-dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
- let bound_vars = mkVarSet (collectLStmtBinders stmt)
- let local_vars' = bound_vars `unionVarSet` local_vars
- (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
- (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
- return (do_compose ids
- (mkBigCoreVarTupTy env_ids)
- (mkBigCoreVarTupTy env_ids')
- res_ty
- core_stmt
- core_stmts,
- fv_stmt)
-
-{-
-A statement maps one local environment to another, and is represented
-as an arrow from one tuple type to another. A statement sequence is
-translated to a composition of such arrows.
--}
-
-dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id]
- -> DsM (CoreExpr, DIdSet)
-dsCmdLStmt ids local_vars out_ids cmd env_ids
- = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
-
-dsCmdStmt
- :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this statement
- -> [Id] -- list of vars in the output of this statement
- -> CmdStmt GhcTc -- statement to desugar
- -> [Id] -- list of vars in the input to this statement
- -- This is typically fed back,
- -- so don't pull on it too early
- -> DsM (CoreExpr, -- desugared expression
- DIdSet) -- subset of local vars that occur free
-
--- D; xs1 |-a c : () --> t
--- D; xs' |-a do { ss } : t'
--- ------------------------------
--- D; xs |-a do { c; ss } : t'
---
--- ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
--- (first c >>> arr snd) >>> ss
-
-dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
- (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
- core_mux <- matchEnv env_ids
- (mkCorePairExpr
- (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
- (mkBigCoreVarTup out_ids))
- let
- in_ty = mkBigCoreVarTupTy env_ids
- in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
- out_ty = mkBigCoreVarTupTy out_ids
- before_c_ty = mkCorePairTy in_ty1 out_ty
- after_c_ty = mkCorePairTy c_ty out_ty
- dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here
- snd_fn <- mkSndExpr c_ty out_ty
- return (do_premap ids in_ty before_c_ty out_ty core_mux $
- do_compose ids before_c_ty after_c_ty out_ty
- (do_first ids in_ty1 c_ty out_ty core_cmd) $
- do_arr ids after_c_ty out_ty snd_fn,
- extendDVarSetList fv_cmd out_ids)
-
--- D; xs1 |-a c : () --> t
--- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p)
--- -----------------------------------
--- D; xs |-a do { p <- c; ss } : t'
---
--- ---> premap (\ (xs) -> (((xs1),()),(xs2)))
--- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
---
--- It would be simpler and more consistent to do this using second,
--- but that's likely to be defined in terms of first.
-
-dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
- let pat_ty = hsLPatType pat
- (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
- let pat_vars = mkVarSet (collectPatBinders pat)
- let
- env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids
- env_ty2 = mkBigCoreVarTupTy env_ids2
-
- -- multiplexing function
- -- \ (xs) -> (((xs1),()),(xs2))
-
- core_mux <- matchEnv env_ids
- (mkCorePairExpr
- (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
- (mkBigCoreVarTup env_ids2))
-
- -- projection function
- -- \ (p, (xs2)) -> (zs)
-
- env_id <- newSysLocalDs env_ty2
- uniqs <- newUniqueSupply
- let
- after_c_ty = mkCorePairTy pat_ty env_ty2
- out_ty = mkBigCoreVarTupTy out_ids
- body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
-
- fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
- pat_id <- selectSimpleMatchVarL pat
- match_code
- <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
- pair_id <- newSysLocalDs after_c_ty
- let
- proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
-
- -- put it all together
- let
- in_ty = mkBigCoreVarTupTy env_ids
- in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
- in_ty2 = mkBigCoreVarTupTy env_ids2
- before_c_ty = mkCorePairTy in_ty1 in_ty2
- return (do_premap ids in_ty before_c_ty out_ty core_mux $
- do_compose ids before_c_ty after_c_ty out_ty
- (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
- do_arr ids after_c_ty out_ty proj_expr,
- fv_cmd `unionDVarSet` (mkDVarSet out_ids
- `uniqDSetMinusUniqSet` pat_vars))
-
--- D; xs' |-a do { ss } : t
--- --------------------------------------
--- D; xs |-a do { let binds; ss } : t
---
--- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
-
-dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do
- -- build a new environment using the let bindings
- core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
- -- match the old environment against the input
- core_map <- matchEnv env_ids core_binds
- return (do_arr ids
- (mkBigCoreVarTupTy env_ids)
- (mkBigCoreVarTupTy out_ids)
- core_map,
- exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
-
--- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
--- D; xs' |-a do { ss' } : t
--- ------------------------------------
--- D; xs |-a do { rec ss; ss' } : t
---
--- xs1 = xs' /\ defs(ss)
--- xs2 = xs' - defs(ss)
--- ys1 = ys - defs(ss)
--- ys2 = ys /\ defs(ss)
---
--- ---> arr (\(xs) -> ((ys1),(xs2))) >>>
--- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
--- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
-
-dsCmdStmt ids local_vars out_ids
- (RecStmt { recS_stmts = stmts
- , recS_later_ids = later_ids, recS_rec_ids = rec_ids
- , recS_ext = RecStmtTc { recS_later_rets = later_rets
- , recS_rec_rets = rec_rets } })
- env_ids = do
- let
- later_ids_set = mkVarSet later_ids
- env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids
- env2_id_set = mkDVarSet env2_ids
- env2_ty = mkBigCoreVarTupTy env2_ids
-
- -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
-
- uniqs <- newUniqueSupply
- env2_id <- newSysLocalDs env2_ty
- let
- later_ty = mkBigCoreVarTupTy later_ids
- post_pair_ty = mkCorePairTy later_ty env2_ty
- post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
-
- post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
-
- --- loop (...)
-
- (core_loop, env1_id_set, env1_ids)
- <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
-
- -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
-
- let
- env1_ty = mkBigCoreVarTupTy env1_ids
- pre_pair_ty = mkCorePairTy env1_ty env2_ty
- pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
- (mkBigCoreVarTup env2_ids)
-
- pre_loop_fn <- matchEnv env_ids pre_loop_body
-
- -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
-
- let
- env_ty = mkBigCoreVarTupTy env_ids
- out_ty = mkBigCoreVarTupTy out_ids
- core_body = do_premap ids env_ty pre_pair_ty out_ty
- pre_loop_fn
- (do_compose ids pre_pair_ty post_pair_ty out_ty
- (do_first ids env1_ty later_ty env2_ty
- core_loop)
- (do_arr ids post_pair_ty out_ty
- post_loop_fn))
-
- return (core_body, env1_id_set `unionDVarSet` env2_id_set)
-
-dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
-
--- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
--- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
-
-dsRecCmd
- :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this statement
- -> [CmdLStmt GhcTc] -- list of statements inside the RecCmd
- -> [Id] -- list of vars defined here and used later
- -> [HsExpr GhcTc] -- expressions corresponding to later_ids
- -> [Id] -- list of vars fed back through the loop
- -> [HsExpr GhcTc] -- expressions corresponding to rec_ids
- -> DsM (CoreExpr, -- desugared statement
- DIdSet, -- subset of local vars that occur free
- [Id]) -- same local vars as a list
-
-dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
- let
- later_id_set = mkVarSet later_ids
- rec_id_set = mkVarSet rec_ids
- local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
-
- -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
-
- core_later_rets <- mapM dsExpr later_rets
- core_rec_rets <- mapM dsExpr rec_rets
- let
- -- possibly polymorphic version of vars of later_ids and rec_ids
- out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)
- out_ty = mkBigCoreVarTupTy out_ids
-
- later_tuple = mkBigCoreTup core_later_rets
- later_ty = mkBigCoreVarTupTy later_ids
-
- rec_tuple = mkBigCoreTup core_rec_rets
- rec_ty = mkBigCoreVarTupTy rec_ids
-
- out_pair = mkCorePairExpr later_tuple rec_tuple
- out_pair_ty = mkCorePairTy later_ty rec_ty
-
- mk_pair_fn <- matchEnv out_ids out_pair
-
- -- ss
-
- (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
-
- -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
-
- rec_id <- newSysLocalDs rec_ty
- let
- env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set
- env1_ids = dVarSetElems env1_id_set
- env1_ty = mkBigCoreVarTupTy env1_ids
- in_pair_ty = mkCorePairTy env1_ty rec_ty
- core_body = mkBigCoreTup (map selectVar env_ids)
- where
- selectVar v
- | v `elemVarSet` rec_id_set
- = mkTupleSelector rec_ids v rec_id (Var rec_id)
- | otherwise = Var v
-
- squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
-
- -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
-
- let
- env_ty = mkBigCoreVarTupTy env_ids
- core_loop = do_loop ids env1_ty later_ty rec_ty
- (do_premap ids in_pair_ty env_ty out_pair_ty
- squash_pair_fn
- (do_compose ids env_ty out_ty out_pair_ty
- core_stmts
- (do_arr ids out_ty out_pair_ty mk_pair_fn)))
-
- return (core_loop, env1_id_set, env1_ids)
-
-{-
-A sequence of statements (as in a rec) is desugared to an arrow between
-two environments (no stack)
--}
-
-dsfixCmdStmts
- :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this statement
- -> [Id] -- output vars of these statements
- -> [CmdLStmt GhcTc] -- statements to desugar
- -> DsM (CoreExpr, -- desugared expression
- DIdSet, -- subset of local vars that occur free
- [Id]) -- same local vars as a list
-
-dsfixCmdStmts ids local_vars out_ids stmts
- = trimInput (dsCmdStmts ids local_vars out_ids stmts)
- -- TODO: Add levity polymorphism check for the resulting expression.
- -- But I (Richard E.) don't know enough about arrows to do so.
-
-dsCmdStmts
- :: DsCmdEnv -- arrow combinators
- -> IdSet -- set of local vars available to this statement
- -> [Id] -- output vars of these statements
- -> [CmdLStmt GhcTc] -- statements to desugar
- -> [Id] -- list of vars in the input to these statements
- -> DsM (CoreExpr, -- desugared expression
- DIdSet) -- subset of local vars that occur free
-
-dsCmdStmts ids local_vars out_ids [stmt] env_ids
- = dsCmdLStmt ids local_vars out_ids stmt env_ids
-
-dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
- let bound_vars = mkVarSet (collectLStmtBinders stmt)
- let local_vars' = bound_vars `unionVarSet` local_vars
- (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
- (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
- return (do_compose ids
- (mkBigCoreVarTupTy env_ids)
- (mkBigCoreVarTupTy env_ids')
- (mkBigCoreVarTupTy out_ids)
- core_stmt
- core_stmts,
- fv_stmt)
-
-dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
-
--- Match a list of expressions against a list of patterns, left-to-right.
-
-matchSimplys :: [CoreExpr] -- Scrutinees
- -> HsMatchContext GhcRn -- Match kind
- -> [LPat GhcTc] -- Patterns they should match
- -> CoreExpr -- Return this if they all match
- -> CoreExpr -- Return this if they don't
- -> DsM CoreExpr
-matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
-matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
- match_code <- matchSimplys exps ctxt pats result_expr fail_expr
- matchSimply exp ctxt pat match_code fail_expr
-matchSimplys _ _ _ _ _ = panic "matchSimplys"
-
--- List of leaf expressions, with set of variables bound in each
-
-leavesMatch :: LMatch GhcTc (Located (body GhcTc))
- -> [(Located (body GhcTc), IdSet)]
-leavesMatch (L _ (Match { m_pats = pats
- , m_grhss = GRHSs _ grhss (L _ binds) }))
- = let
- defined_vars = mkVarSet (collectPatsBinders pats)
- `unionVarSet`
- mkVarSet (collectLocalBinders binds)
- in
- [(body,
- mkVarSet (collectLStmtsBinders stmts)
- `unionVarSet` defined_vars)
- | L _ (GRHS _ stmts body) <- grhss]
-leavesMatch _ = panic "leavesMatch"
-
--- Replace the leaf commands in a match
-
-replaceLeavesMatch
- :: Type -- new result type
- -> [Located (body' GhcTc)] -- replacement leaf expressions of that type
- -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command
- -> ([Located (body' GhcTc)], -- remaining leaf expressions
- LMatch GhcTc (Located (body' GhcTc))) -- updated match
-replaceLeavesMatch _res_ty leaves
- (L loc
- match@(Match { m_grhss = GRHSs x grhss binds }))
- = let
- (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
- in
- (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds }))
-replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch"
-
-replaceLeavesGRHS
- :: [Located (body' GhcTc)] -- replacement leaf expressions of that type
- -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command
- -> ([Located (body' GhcTc)], -- remaining leaf expressions
- LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS
-replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))
- = (leaves, L loc (GRHS x stmts leaf))
-replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
-replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS"
-
--- Balanced fold of a non-empty list.
-
-foldb :: (a -> a -> a) -> [a] -> a
-foldb _ [] = error "foldb of empty list"
-foldb _ [x] = x
-foldb f xs = foldb f (fold_pairs xs)
- where
- fold_pairs [] = []
- fold_pairs [x] = [x]
- fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
-
-{-
-Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The following functions to collect value variables from patterns are
-copied from GHC.Hs.Utils, with one change: we also collect the dictionary
-bindings (pat_binds) from ConPatOut. We need them for cases like
-
-h :: Arrow a => Int -> a (Int,Int) Int
-h x = proc (y,z) -> case compare x y of
- GT -> returnA -< z+x
-
-The type checker turns the case into
-
- case compare x y of
- GT { p77 = plusInt } -> returnA -< p77 z x
-
-Here p77 is a local binding for the (+) operation.
-
-See comments in GHC.Hs.Utils for why the other version does not include
-these bindings.
--}
-
-collectPatBinders :: LPat GhcTc -> [Id]
-collectPatBinders pat = collectl pat []
-
-collectPatsBinders :: [LPat GhcTc] -> [Id]
-collectPatsBinders pats = foldr collectl [] pats
-
----------------------
-collectl :: LPat GhcTc -> [Id] -> [Id]
--- See Note [Dictionary binders in ConPatOut]
-collectl (L _ pat) bndrs
- = go pat
- where
- go (VarPat _ (L _ var)) = var : bndrs
- go (WildPat _) = bndrs
- go (LazyPat _ pat) = collectl pat bndrs
- go (BangPat _ pat) = collectl pat bndrs
- go (AsPat _ (L _ a) pat) = a : collectl pat bndrs
- go (ParPat _ pat) = collectl pat bndrs
-
- go (ListPat _ pats) = foldr collectl bndrs pats
- go (TuplePat _ pats _) = foldr collectl bndrs pats
- go (SumPat _ pat _ _) = collectl pat bndrs
-
- go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
- go (ConPatOut {pat_args=ps, pat_binds=ds}) =
- collectEvBinders ds
- ++ foldr collectl bndrs (hsConPatArgs ps)
- go (LitPat _ _) = bndrs
- go (NPat {}) = bndrs
- go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
-
- go (SigPat _ pat _) = collectl pat bndrs
- go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
- go (ViewPat _ _ pat) = collectl pat bndrs
- go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
- go p@(XPat {}) = pprPanic "collectl/go" (ppr p)
-
-collectEvBinders :: TcEvBinds -> [Id]
-collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs
-collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
-
-add_ev_bndr :: EvBind -> [Id] -> [Id]
-add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs
- | otherwise = bs
- -- A worry: what about coercion variable binders??
-
-collectLStmtsBinders :: [LStmt GhcTc body] -> [Id]
-collectLStmtsBinders = concatMap collectLStmtBinders
-
-collectLStmtBinders :: LStmt GhcTc body -> [Id]
-collectLStmtBinders = collectStmtBinders . unLoc
-
-collectStmtBinders :: Stmt GhcTc body -> [Id]
-collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
-collectStmtBinders stmt = HsUtils.collectStmtBinders stmt
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
deleted file mode 100644
index d573efc0c3..0000000000
--- a/compiler/deSugar/DsBinds.hs
+++ /dev/null
@@ -1,1325 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Pattern-matching bindings (HsBinds and MonoBinds)
-
-Handles @HsBinds@; those at the top level require different handling,
-in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
-lower levels it is preserved with @let@/@letrec@s).
--}
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
- dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
- ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import {-# SOURCE #-} DsExpr( dsLExpr )
-import {-# SOURCE #-} Match( matchWrapper )
-
-import DsMonad
-import DsGRHSs
-import DsUtils
-import GHC.HsToCore.PmCheck ( needToRunPmCheck, addTyCsDs, checkGuardMatches )
-
-import GHC.Hs -- lots of things
-import CoreSyn -- lots of things
-import CoreOpt ( simpleOptExpr )
-import OccurAnal ( occurAnalyseExpr )
-import MkCore
-import CoreUtils
-import CoreArity ( etaExpand )
-import CoreUnfold
-import CoreFVs
-import Digraph
-import Predicate
-
-import PrelNames
-import TyCon
-import TcEvidence
-import TcType
-import Type
-import Coercion
-import TysWiredIn ( typeNatKind, typeSymbolKind )
-import Id
-import MkId(proxyHashId)
-import Name
-import VarSet
-import Rules
-import VarEnv
-import Var( EvVar )
-import Outputable
-import Module
-import SrcLoc
-import Maybes
-import OrdList
-import Bag
-import BasicTypes
-import DynFlags
-import FastString
-import Util
-import UniqSet( nonDetEltsUniqSet )
-import MonadUtils
-import qualified GHC.LanguageExtensions as LangExt
-import Control.Monad
-
-{-**********************************************************************
-* *
- Desugaring a MonoBinds
-* *
-**********************************************************************-}
-
--- | Desugar top level binds, strict binds are treated like normal
--- binds since there is no good time to force before first usage.
-dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
-dsTopLHsBinds binds
- -- see Note [Strict binds checks]
- | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
- = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds
- ; mapBagM_ (top_level_err "strict bindings") bang_binds
- ; return nilOL }
-
- | otherwise
- = do { (force_vars, prs) <- dsLHsBinds binds
- ; when debugIsOn $
- do { xstrict <- xoptM LangExt.Strict
- ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }
- -- with -XStrict, even top-level vars are listed as force vars.
-
- ; return (toOL prs) }
-
- where
- unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
- bang_binds = filterBag (isBangedHsBind . unLoc) binds
-
- top_level_err desc (L loc bind)
- = putSrcSpanDs loc $
- errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")
- 2 (ppr bind))
-
-
--- | Desugar all other kind of bindings, Ids of strict binds are returned to
--- later be forced in the binding group body, see Note [Desugar Strict binds]
-dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
-dsLHsBinds binds
- = do { ds_bs <- mapBagM dsLHsBind binds
- ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
- id ([], []) ds_bs) }
-
-------------------------
-dsLHsBind :: LHsBind GhcTc
- -> DsM ([Id], [(Id,CoreExpr)])
-dsLHsBind (L loc bind) = do dflags <- getDynFlags
- putSrcSpanDs loc $ dsHsBind dflags bind
-
--- | Desugar a single binding (or group of recursive binds).
-dsHsBind :: DynFlags
- -> HsBind GhcTc
- -> DsM ([Id], [(Id,CoreExpr)])
- -- ^ The Ids of strict binds, to be forced in the body of the
- -- binding group see Note [Desugar Strict binds] and all
- -- bindings and their desugared right hand sides.
-
-dsHsBind dflags (VarBind { var_id = var
- , var_rhs = expr
- , var_inline = inline_regardless })
- = do { core_expr <- dsLExpr expr
- -- Dictionary bindings are always VarBinds,
- -- so we only need do this here
- ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
- | otherwise = var
- ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr
- force_var = if xopt LangExt.Strict dflags
- then [id]
- else []
- ; return (force_var, [core_bind]) }
-
-dsHsBind dflags b@(FunBind { fun_id = L _ fun
- , fun_matches = matches
- , fun_ext = co_fn
- , fun_tick = tick })
- = do { (args, body) <- matchWrapper
- (mkPrefixFunRhs (noLoc $ idName fun))
- Nothing matches
- ; core_wrap <- dsHsWrapper co_fn
- ; let body' = mkOptTickBox tick body
- rhs = core_wrap (mkLams args body')
- core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
- force_var
- -- Bindings are strict when -XStrict is enabled
- | xopt LangExt.Strict dflags
- , matchGroupArity matches == 0 -- no need to force lambdas
- = [id]
- | isBangedHsBind b
- = [id]
- | otherwise
- = []
- ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)
- -- , ppr (mg_alts matches)
- -- , ppr args, ppr core_binds]) $
- return (force_var, [core_binds]) }
-
-dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
- , pat_ext = NPatBindTc _ ty
- , pat_ticks = (rhs_tick, var_ticks) })
- = do { body_expr <- dsGuarded grhss ty
- ; checkGuardMatches PatBindGuards grhss
- ; let body' = mkOptTickBox rhs_tick body_expr
- pat' = decideBangHood dflags pat
- ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
- -- We silently ignore inline pragmas; no makeCorePair
- -- Not so cool, but really doesn't matter
- ; let force_var' = if isBangedLPat pat'
- then [force_var]
- else []
- ; return (force_var', sel_binds) }
-
-dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
- , abs_exports = exports
- , abs_ev_binds = ev_binds
- , abs_binds = binds, abs_sig = has_sig })
- = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource)
- -- FromSource might not be accurate, but at worst
- -- we do superfluous calls to the pattern match
- -- oracle.
- -- addTyCsDs: push type constraints deeper
- -- for inner pattern match check
- -- See Check, Note [Type and Term Equality Propagation]
- (addTyCsDs (listToBag dicts))
- (dsLHsBinds binds)
-
- ; ds_ev_binds <- dsTcEvBinds_s ev_binds
-
- -- dsAbsBinds does the hard work
- ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
-
-dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
-dsHsBind _ (XHsBindsLR nec) = noExtCon nec
-
-
------------------------
-dsAbsBinds :: DynFlags
- -> [TyVar] -> [EvVar] -> [ABExport GhcTc]
- -> [CoreBind] -- Desugared evidence bindings
- -> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings
- -> Bool -- Single binding with signature
- -> DsM ([Id], [(Id,CoreExpr)])
-
-dsAbsBinds dflags tyvars dicts exports
- ds_ev_binds (force_vars, bind_prs) has_sig
-
- -- A very important common case: one exported variable
- -- Non-recursive bindings come through this way
- -- So do self-recursive bindings
- | [export] <- exports
- , ABE { abe_poly = global_id, abe_mono = local_id
- , abe_wrap = wrap, abe_prags = prags } <- export
- , Just force_vars' <- case force_vars of
- [] -> Just []
- [v] | v == local_id -> Just [global_id]
- _ -> Nothing
- -- If there is a variable to force, it's just the
- -- single variable we are binding here
- = do { core_wrap <- dsHsWrapper wrap -- Usually the identity
-
- ; let rhs = core_wrap $
- mkLams tyvars $ mkLams dicts $
- mkCoreLets ds_ev_binds $
- body
-
- body | has_sig
- , [(_, lrhs)] <- bind_prs
- = lrhs
- | otherwise
- = mkLetRec bind_prs (Var local_id)
-
- ; (spec_binds, rules) <- dsSpecs rhs prags
-
- ; let global_id' = addIdSpecialisations global_id rules
- main_bind = makeCorePair dflags global_id'
- (isDefaultMethod prags)
- (dictArity dicts) rhs
-
- ; return (force_vars', main_bind : fromOL spec_binds) }
-
- -- Another common case: no tyvars, no dicts
- -- In this case we can have a much simpler desugaring
- | null tyvars, null dicts
-
- = do { let mk_bind (ABE { abe_wrap = wrap
- , abe_poly = global
- , abe_mono = local
- , abe_prags = prags })
- = do { core_wrap <- dsHsWrapper wrap
- ; return (makeCorePair dflags global
- (isDefaultMethod prags)
- 0 (core_wrap (Var local))) }
- mk_bind (XABExport nec) = noExtCon nec
- ; main_binds <- mapM mk_bind exports
-
- ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
-
- -- The general case
- -- See Note [Desugaring AbsBinds]
- | otherwise
- = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
- | (lcl_id, rhs) <- bind_prs ]
- -- Monomorphic recursion possible, hence Rec
- new_force_vars = get_new_force_vars force_vars
- locals = map abe_mono exports
- all_locals = locals ++ new_force_vars
- tup_expr = mkBigCoreVarTup all_locals
- tup_ty = exprType tup_expr
- ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
- mkCoreLets ds_ev_binds $
- mkLet core_bind $
- tup_expr
-
- ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
-
- -- Find corresponding global or make up a new one: sometimes
- -- we need to make new export to desugar strict binds, see
- -- Note [Desugar Strict binds]
- ; (exported_force_vars, extra_exports) <- get_exports force_vars
-
- ; let mk_bind (ABE { abe_wrap = wrap
- , abe_poly = global
- , abe_mono = local, abe_prags = spec_prags })
- -- See Note [AbsBinds wrappers] in HsBinds
- = do { tup_id <- newSysLocalDs tup_ty
- ; core_wrap <- dsHsWrapper wrap
- ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
- mkTupleSelector all_locals local tup_id $
- mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
- rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
- ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
- ; let global' = (global `setInlinePragma` defaultInlinePragma)
- `addIdSpecialisations` rules
- -- Kill the INLINE pragma because it applies to
- -- the user written (local) function. The global
- -- Id is just the selector. Hmm.
- ; return ((global', rhs) : fromOL spec_binds) }
- mk_bind (XABExport nec) = noExtCon nec
-
- ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
-
- ; return ( exported_force_vars
- , (poly_tup_id, poly_tup_rhs) :
- concat export_binds_s) }
- where
- inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
- -- the inline pragma from the source
- -- The type checker put the inline pragma
- -- on the *global* Id, so we need to transfer it
- inline_env
- = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
- | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
- , let prag = idInlinePragma gbl_id ]
-
- add_inline :: Id -> Id -- tran
- add_inline lcl_id = lookupVarEnv inline_env lcl_id
- `orElse` lcl_id
-
- global_env :: IdEnv Id -- Maps local Id to its global exported Id
- global_env =
- mkVarEnv [ (local, global)
- | ABE { abe_mono = local, abe_poly = global } <- exports
- ]
-
- -- find variables that are not exported
- get_new_force_vars lcls =
- foldr (\lcl acc -> case lookupVarEnv global_env lcl of
- Just _ -> acc
- Nothing -> lcl:acc)
- [] lcls
-
- -- find exports or make up new exports for force variables
- get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])
- get_exports lcls =
- foldM (\(glbls, exports) lcl ->
- case lookupVarEnv global_env lcl of
- Just glbl -> return (glbl:glbls, exports)
- Nothing -> do export <- mk_export lcl
- let glbl = abe_poly export
- return (glbl:glbls, export:exports))
- ([],[]) lcls
-
- mk_export local =
- do global <- newSysLocalDs
- (exprType (mkLams tyvars (mkLams dicts (Var local))))
- return (ABE { abe_ext = noExtField
- , abe_poly = global
- , abe_mono = local
- , abe_wrap = WpHole
- , abe_prags = SpecPrags [] })
-
--- | This is where we apply INLINE and INLINABLE pragmas. All we need to
--- do is to attach the unfolding information to the Id.
---
--- Other decisions about whether to inline are made in
--- `calcUnfoldingGuidance` but the decision about whether to then expose
--- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal`
--- using this information.
-------------------------
-makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
- -> (Id, CoreExpr)
-makeCorePair dflags gbl_id is_default_method dict_arity rhs
- | is_default_method -- Default methods are *always* inlined
- -- See Note [INLINE and default methods] in TcInstDcls
- = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
-
- | otherwise
- = case inlinePragmaSpec inline_prag of
- NoUserInline -> (gbl_id, rhs)
- NoInline -> (gbl_id, rhs)
- Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
- Inline -> inline_pair
-
- where
- inline_prag = idInlinePragma gbl_id
- inlinable_unf = mkInlinableUnfolding dflags rhs
- inline_pair
- | Just arity <- inlinePragmaSat inline_prag
- -- Add an Unfolding for an INLINE (but not for NOINLINE)
- -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
- , let real_arity = dict_arity + arity
- -- NB: The arity in the InlineRule takes account of the dictionaries
- = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs
- , etaExpand real_arity rhs)
-
- | otherwise
- = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
- (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)
-
-dictArity :: [Var] -> Arity
--- Don't count coercion variables in arity
-dictArity dicts = count isId dicts
-
-{-
-Note [Desugaring AbsBinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-In the general AbsBinds case we desugar the binding to this:
-
- tup a (d:Num a) = let fm = ...gm...
- gm = ...fm...
- in (fm,gm)
- f a d = case tup a d of { (fm,gm) -> fm }
- g a d = case tup a d of { (fm,gm) -> fm }
-
-Note [Rules and inlining]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Common special case: no type or dictionary abstraction
-This is a bit less trivial than you might suppose
-The naive way would be to desugar to something like
- f_lcl = ...f_lcl... -- The "binds" from AbsBinds
- M.f = f_lcl -- Generated from "exports"
-But we don't want that, because if M.f isn't exported,
-it'll be inlined unconditionally at every call site (its rhs is
-trivial). That would be ok unless it has RULES, which would
-thereby be completely lost. Bad, bad, bad.
-
-Instead we want to generate
- M.f = ...f_lcl...
- f_lcl = M.f
-Now all is cool. The RULES are attached to M.f (by SimplCore),
-and f_lcl is rapidly inlined away.
-
-This does not happen in the same way to polymorphic binds,
-because they desugar to
- M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
-Although I'm a bit worried about whether full laziness might
-float the f_lcl binding out and then inline M.f at its call site
-
-Note [Specialising in no-dict case]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Even if there are no tyvars or dicts, we may have specialisation pragmas.
-Class methods can generate
- AbsBinds [] [] [( ... spec-prag]
- { AbsBinds [tvs] [dicts] ...blah }
-So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
-
- class (Real a, Fractional a) => RealFrac a where
- round :: (Integral b) => a -> b
-
- instance RealFrac Float where
- {-# SPECIALIZE round :: Float -> Int #-}
-
-The top-level AbsBinds for $cround has no tyvars or dicts (because the
-instance does not). But the method is locally overloaded!
-
-Note [Abstracting over tyvars only]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When abstracting over type variable only (not dictionaries), we don't really need to
-built a tuple and select from it, as we do in the general case. Instead we can take
-
- AbsBinds [a,b] [ ([a,b], fg, fl, _),
- ([b], gg, gl, _) ]
- { fl = e1
- gl = e2
- h = e3 }
-
-and desugar it to
-
- fg = /\ab. let B in e1
- gg = /\b. let a = () in let B in S(e2)
- h = /\ab. let B in e3
-
-where B is the *non-recursive* binding
- fl = fg a b
- gl = gg b
- h = h a b -- See (b); note shadowing!
-
-Notice (a) g has a different number of type variables to f, so we must
- use the mkArbitraryType thing to fill in the gaps.
- We use a type-let to do that.
-
- (b) The local variable h isn't in the exports, and rather than
- clone a fresh copy we simply replace h by (h a b), where
- the two h's have different types! Shadowing happens here,
- which looks confusing but works fine.
-
- (c) The result is *still* quadratic-sized if there are a lot of
- small bindings. So if there are more than some small
- number (10), we filter the binding set B by the free
- variables of the particular RHS. Tiresome.
-
-Why got to this trouble? It's a common case, and it removes the
-quadratic-sized tuple desugaring. Less clutter, hopefully faster
-compilation, especially in a case where there are a *lot* of
-bindings.
-
-
-Note [Eta-expanding INLINE things]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- foo :: Eq a => a -> a
- {-# INLINE foo #-}
- foo x = ...
-
-If (foo d) ever gets floated out as a common sub-expression (which can
-happen as a result of method sharing), there's a danger that we never
-get to do the inlining, which is a Terribly Bad thing given that the
-user said "inline"!
-
-To avoid this we pre-emptively eta-expand the definition, so that foo
-has the arity with which it is declared in the source code. In this
-example it has arity 2 (one for the Eq and one for x). Doing this
-should mean that (foo d) is a PAP and we don't share it.
-
-Note [Nested arities]
-~~~~~~~~~~~~~~~~~~~~~
-For reasons that are not entirely clear, method bindings come out looking like
-this:
-
- AbsBinds [] [] [$cfromT <= [] fromT]
- $cfromT [InlPrag=INLINE] :: T Bool -> Bool
- { AbsBinds [] [] [fromT <= [] fromT_1]
- fromT :: T Bool -> Bool
- { fromT_1 ((TBool b)) = not b } } }
-
-Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
-gotten from the binding for fromT_1.
-
-It might be better to have just one level of AbsBinds, but that requires more
-thought!
-
-
-Note [Desugar Strict binds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma
-
-Desugaring strict variable bindings looks as follows (core below ==>)
-
- let !x = rhs
- in body
-==>
- let x = rhs
- in x `seq` body -- seq the variable
-
-and if it is a pattern binding the desugaring looks like
-
- let !pat = rhs
- in body
-==>
- let x = rhs -- bind the rhs to a new variable
- pat = x
- in x `seq` body -- seq the new variable
-
-if there is no variable in the pattern desugaring looks like
-
- let False = rhs
- in body
-==>
- let x = case rhs of {False -> (); _ -> error "Match failed"}
- in x `seq` body
-
-In order to force the Ids in the binding group they are passed around
-in the dsHsBind family of functions, and later seq'ed in DsExpr.ds_val_bind.
-
-Consider a recursive group like this
-
- letrec
- f : g = rhs[f,g]
- in <body>
-
-Without `Strict`, we get a translation like this:
-
- let t = /\a. letrec tm = rhs[fm,gm]
- fm = case t of fm:_ -> fm
- gm = case t of _:gm -> gm
- in
- (fm,gm)
-
- in let f = /\a. case t a of (fm,_) -> fm
- in let g = /\a. case t a of (_,gm) -> gm
- in <body>
-
-Here `tm` is the monomorphic binding for `rhs`.
-
-With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.
-Alas, `tm` isn't in scope in the `in <body>` part.
-
-The simplest thing is to return it in the polymorphic
-tuple `t`, thus:
-
- let t = /\a. letrec tm = rhs[fm,gm]
- fm = case t of fm:_ -> fm
- gm = case t of _:gm -> gm
- in
- (tm, fm, gm)
-
- in let f = /\a. case t a of (_,fm,_) -> fm
- in let g = /\a. case t a of (_,_,gm) -> gm
- in let tm = /\a. case t a of (tm,_,_) -> tm
- in tm `seq` <body>
-
-
-See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more
-detailed explanation of the desugaring of strict bindings.
-
-Note [Strict binds checks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are several checks around properly formed strict bindings. They
-all link to this Note. These checks must be here in the desugarer because
-we cannot know whether or not a type is unlifted until after zonking, due
-to levity polymorphism. These checks all used to be handled in the typechecker
-in checkStrictBinds (before Jan '17).
-
-We define an "unlifted bind" to be any bind that binds an unlifted id. Note that
-
- x :: Char
- (# True, x #) = blah
-
-is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind.
-
-Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind.
-Define a "strict bind" to be either an unlifted bind or a banged bind.
-
-The restrictions are:
- 1. Strict binds may not be top-level. Checked in dsTopLHsBinds.
-
- 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged
- unlifted bind, but an unbanged bind looks lazy, and we don't want users to be
- surprised by the strictness of an unlifted bind.) Checked in first clause
- of DsExpr.ds_val_bind.
-
- 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type
- variables or constraints.) Checked in first clause
- of DsExpr.ds_val_bind.
-
- 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.
-
--}
-
-------------------------
-dsSpecs :: CoreExpr -- Its rhs
- -> TcSpecPrags
- -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
- , [CoreRule] ) -- Rules for the Global Ids
--- See Note [Handling SPECIALISE pragmas] in TcBinds
-dsSpecs _ IsDefaultMethod = return (nilOL, [])
-dsSpecs poly_rhs (SpecPrags sps)
- = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
- ; let (spec_binds_s, rules) = unzip pairs
- ; return (concatOL spec_binds_s, rules) }
-
-dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
- -- Nothing => RULE is for an imported Id
- -- rhs is in the Id's unfolding
- -> Located TcSpecPrag
- -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
- | isJust (isClassOpId_maybe poly_id)
- = putSrcSpanDs loc $
- do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"
- <+> quotes (ppr poly_id))
- ; return Nothing } -- There is no point in trying to specialise a class op
- -- Moreover, classops don't (currently) have an inl_sat arity set
- -- (it would be Just 0) and that in turn makes makeCorePair bleat
-
- | no_act_spec && isNeverActive rule_act
- = putSrcSpanDs loc $
- do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
- <+> quotes (ppr poly_id))
- ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that
- -- See Note [Activation pragmas for SPECIALISE]
-
- | otherwise
- = putSrcSpanDs loc $
- do { uniq <- newUnique
- ; let poly_name = idName poly_id
- spec_occ = mkSpecOcc (getOccName poly_name)
- spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
- (spec_bndrs, spec_app) = collectHsWrapBinders spec_co
- -- spec_co looks like
- -- \spec_bndrs. [] spec_args
- -- perhaps with the body of the lambda wrapped in some WpLets
- -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
-
- ; core_app <- dsHsWrapper spec_app
-
- ; let ds_lhs = core_app (Var poly_id)
- spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)
- ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
- -- , text "spec_co:" <+> ppr spec_co
- -- , text "ds_rhs:" <+> ppr ds_lhs ]) $
- dflags <- getDynFlags
- ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {
- Left msg -> do { warnDs NoReason msg; return Nothing } ;
- Right (rule_bndrs, _fn, args) -> do
-
- { this_mod <- getModule
- ; let fn_unf = realIdUnfolding poly_id
- spec_unf = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf
- spec_id = mkLocalId spec_name spec_ty
- `setInlinePragma` inl_prag
- `setIdUnfolding` spec_unf
- arity_decrease = count isValArg args - count isId spec_bndrs
-
- ; rule <- dsMkUserRule this_mod is_local_id
- (mkFastString ("SPEC " ++ showPpr dflags poly_name))
- rule_act poly_name
- rule_bndrs args
- (mkVarApps (Var spec_id) spec_bndrs)
-
- ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
-
--- Commented out: see Note [SPECIALISE on INLINE functions]
--- ; when (isInlinePragma id_inl)
--- (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"
--- <+> quotes (ppr poly_name))
-
- ; return (Just (unitOL (spec_id, spec_rhs), rule))
- -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
- -- makeCorePair overwrites the unfolding, which we have
- -- just created using specUnfolding
- } } }
- where
- is_local_id = isJust mb_poly_rhs
- poly_rhs | Just rhs <- mb_poly_rhs
- = rhs -- Local Id; this is its rhs
- | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
- = unfolding -- Imported Id; this is its unfolding
- -- Use realIdUnfolding so we get the unfolding
- -- even when it is a loop breaker.
- -- We want to specialise recursive functions!
- | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
- -- The type checker has checked that it *has* an unfolding
-
- id_inl = idInlinePragma poly_id
-
- -- See Note [Activation pragmas for SPECIALISE]
- inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl
- | not is_local_id -- See Note [Specialising imported functions]
- -- in OccurAnal
- , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
- | otherwise = id_inl
- -- Get the INLINE pragma from SPECIALISE declaration, or,
- -- failing that, from the original Id
-
- spec_prag_act = inlinePragmaActivation spec_inl
-
- -- See Note [Activation pragmas for SPECIALISE]
- -- no_act_spec is True if the user didn't write an explicit
- -- phase specification in the SPECIALISE pragma
- no_act_spec = case inlinePragmaSpec spec_inl of
- NoInline -> isNeverActive spec_prag_act
- _ -> isAlwaysActive spec_prag_act
- rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit
- | otherwise = spec_prag_act -- Specified by user
-
-
-dsMkUserRule :: Module -> Bool -> RuleName -> Activation
- -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
-dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
- let rule = mkRule this_mod False is_local name act fn bndrs args rhs
- dflags <- getDynFlags
- when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
- warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule)
- return rule
-
-ruleOrphWarn :: CoreRule -> SDoc
-ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule
-
-{- Note [SPECIALISE on INLINE functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to warn that using SPECIALISE for a function marked INLINE
-would be a no-op; but it isn't! Especially with worker/wrapper split
-we might have
- {-# INLINE f #-}
- f :: Ord a => Int -> a -> ...
- f d x y = case x of I# x' -> $wf d x' y
-
-We might want to specialise 'f' so that we in turn specialise '$wf'.
-We can't even /name/ '$wf' in the source code, so we can't specialise
-it even if we wanted to. #10721 is a case in point.
-
-Note [Activation pragmas for SPECIALISE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-From a user SPECIALISE pragma for f, we generate
- a) A top-level binding spec_fn = rhs
- b) A RULE f dOrd = spec_fn
-
-We need two pragma-like things:
-
-* spec_fn's inline pragma: inherited from f's inline pragma (ignoring
- activation on SPEC), unless overridden by SPEC INLINE
-
-* Activation of RULE: from SPECIALISE pragma (if activation given)
- otherwise from f's inline pragma
-
-This is not obvious (see #5237)!
-
-Examples Rule activation Inline prag on spec'd fn
----------------------------------------------------------------------
-SPEC [n] f :: ty [n] Always, or NOINLINE [n]
- copy f's prag
-
-NOINLINE f
-SPEC [n] f :: ty [n] NOINLINE
- copy f's prag
-
-NOINLINE [k] f
-SPEC [n] f :: ty [n] NOINLINE [k]
- copy f's prag
-
-INLINE [k] f
-SPEC [n] f :: ty [n] INLINE [k]
- copy f's prag
-
-SPEC INLINE [n] f :: ty [n] INLINE [n]
- (ignore INLINE prag on f,
- same activation for rule and spec'd fn)
-
-NOINLINE [k] f
-SPEC f :: ty [n] INLINE [k]
-
-
-************************************************************************
-* *
-\subsection{Adding inline pragmas}
-* *
-************************************************************************
--}
-
-decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
- -> Either SDoc ([Var], Id, [CoreExpr])
--- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
--- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
--- may add some extra dictionary binders (see Note [Free dictionaries])
---
--- Returns an error message if the LHS isn't of the expected shape
--- Note [Decomposing the left-hand side of a RULE]
-decomposeRuleLhs dflags orig_bndrs orig_lhs
- | not (null unbound) -- Check for things unbound on LHS
- -- See Note [Unused spec binders]
- = Left (vcat (map dead_msg unbound))
- | Var funId <- fun2
- , Just con <- isDataConId_maybe funId
- = Left (constructor_msg con) -- See Note [No RULES on datacons]
- | Just (fn_id, args) <- decompose fun2 args2
- , let extra_bndrs = mk_extra_bndrs fn_id args
- = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
- -- , text "orig_lhs:" <+> ppr orig_lhs
- -- , text "lhs1:" <+> ppr lhs1
- -- , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs
- -- , text "fn_id:" <+> ppr fn_id
- -- , text "args:" <+> ppr args]) $
- Right (orig_bndrs ++ extra_bndrs, fn_id, args)
-
- | otherwise
- = Left bad_shape_msg
- where
- lhs1 = drop_dicts orig_lhs
- lhs2 = simpleOptExpr dflags lhs1 -- See Note [Simplify rule LHS]
- (fun2,args2) = collectArgs lhs2
-
- lhs_fvs = exprFreeVars lhs2
- unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
-
- orig_bndr_set = mkVarSet orig_bndrs
-
- -- Add extra tyvar binders: Note [Free tyvars in rule LHS]
- -- and extra dict binders: Note [Free dictionaries in rule LHS]
- mk_extra_bndrs fn_id args
- = scopedSort unbound_tvs ++ unbound_dicts
- where
- unbound_tvs = [ v | v <- unbound_vars, isTyVar v ]
- unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d)
- | d <- unbound_vars, isDictId d ]
- unbound_vars = [ v | v <- exprsFreeVarsList args
- , not (v `elemVarSet` orig_bndr_set)
- , not (v == fn_id) ]
- -- fn_id: do not quantify over the function itself, which may
- -- itself be a dictionary (in pathological cases, #10251)
-
- decompose (Var fn_id) args
- | not (fn_id `elemVarSet` orig_bndr_set)
- = Just (fn_id, args)
-
- decompose _ _ = Nothing
-
- bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar")
- 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
- , text "Orig lhs:" <+> ppr orig_lhs])
- dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr
- , text "is not bound in RULE lhs"])
- 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
- , text "Orig lhs:" <+> ppr orig_lhs
- , text "optimised lhs:" <+> ppr lhs2 ])
- pp_bndr bndr
- | isTyVar bndr = text "type variable" <+> quotes (ppr bndr)
- | isEvVar bndr = text "constraint" <+> quotes (ppr (varType bndr))
- | otherwise = text "variable" <+> quotes (ppr bndr)
-
- constructor_msg con = vcat
- [ text "A constructor," <+> ppr con <>
- text ", appears as outermost match in RULE lhs."
- , text "This rule will be ignored." ]
-
- drop_dicts :: CoreExpr -> CoreExpr
- drop_dicts e
- = wrap_lets needed bnds body
- where
- needed = orig_bndr_set `minusVarSet` exprFreeVars body
- (bnds, body) = split_lets (occurAnalyseExpr e)
- -- The occurAnalyseExpr drops dead bindings which is
- -- crucial to ensure that every binding is used later;
- -- which in turn makes wrap_lets work right
-
- split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
- split_lets (Let (NonRec d r) body)
- | isDictId d
- = ((d,r):bs, body')
- where (bs, body') = split_lets body
-
- -- handle "unlifted lets" too, needed for "map/coerce"
- split_lets (Case r d _ [(DEFAULT, _, body)])
- | isCoVar d
- = ((d,r):bs, body')
- where (bs, body') = split_lets body
-
- split_lets e = ([], e)
-
- wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
- wrap_lets _ [] body = body
- wrap_lets needed ((d, r) : bs) body
- | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body)
- | otherwise = wrap_lets needed bs body
- where
- rhs_fvs = exprFreeVars r
- needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
-
-{-
-Note [Decomposing the left-hand side of a RULE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are several things going on here.
-* drop_dicts: see Note [Drop dictionary bindings on rule LHS]
-* simpleOptExpr: see Note [Simplify rule LHS]
-* extra_dict_bndrs: see Note [Free dictionaries]
-
-Note [Free tyvars on rule LHS]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- data T a = C
-
- foo :: T a -> Int
- foo C = 1
-
- {-# RULES "myrule" foo C = 1 #-}
-
-After type checking the LHS becomes (foo alpha (C alpha)), where alpha
-is an unbound meta-tyvar. The zonker in TcHsSyn is careful not to
-turn the free alpha into Any (as it usually does). Instead it turns it
-into a TyVar 'a'. See TcHsSyn Note [Zonking the LHS of a RULE].
-
-Now we must quantify over that 'a'. It's /really/ inconvenient to do that
-in the zonker, because the HsExpr data type is very large. But it's /easy/
-to do it here in the desugarer.
-
-Moreover, we have to do something rather similar for dictionaries;
-see Note [Free dictionaries on rule LHS]. So that's why we look for
-type variables free on the LHS, and quantify over them.
-
-Note [Free dictionaries on rule LHS]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
-which is presumably in scope at the function definition site, we can quantify
-over it too. *Any* dict with that type will do.
-
-So for example when you have
- f :: Eq a => a -> a
- f = <rhs>
- ... SPECIALISE f :: Int -> Int ...
-
-Then we get the SpecPrag
- SpecPrag (f Int dInt)
-
-And from that we want the rule
-
- RULE forall dInt. f Int dInt = f_spec
- f_spec = let f = <rhs> in f Int dInt
-
-But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
-Name, and you can't bind them in a lambda or forall without getting things
-confused. Likewise it might have an InlineRule or something, which would be
-utterly bogus. So we really make a fresh Id, with the same unique and type
-as the old one, but with an Internal name and no IdInfo.
-
-Note [Drop dictionary bindings on rule LHS]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-drop_dicts drops dictionary bindings on the LHS where possible.
- E.g. let d:Eq [Int] = $fEqList $fEqInt in f d
- --> f d
- Reasoning here is that there is only one d:Eq [Int], and so we can
- quantify over it. That makes 'd' free in the LHS, but that is later
- picked up by extra_dict_bndrs (Note [Dead spec binders]).
-
- NB 1: We can only drop the binding if the RHS doesn't bind
- one of the orig_bndrs, which we assume occur on RHS.
- Example
- f :: (Eq a) => b -> a -> a
- {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
- Here we want to end up with
- RULE forall d:Eq a. f ($dfEqList d) = f_spec d
- Of course, the ($dfEqlist d) in the pattern makes it less likely
- to match, but there is no other way to get d:Eq a
-
- NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
- the evidence bindings to be wrapped around the outside of the
- LHS. (After simplOptExpr they'll usually have been inlined.)
- dsHsWrapper does dependency analysis, so that civilised ones
- will be simple NonRec bindings. We don't handle recursive
- dictionaries!
-
- NB3: In the common case of a non-overloaded, but perhaps-polymorphic
- specialisation, we don't need to bind *any* dictionaries for use
- in the RHS. For example (#8331)
- {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
- useAbstractMonad :: MonadAbstractIOST m => m Int
- Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
- but the RHS uses no dictionaries, so we want to end up with
- RULE forall s (d :: MonadAbstractIOST (ReaderT s)).
- useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
-
- #8848 is a good example of where there are some interesting
- dictionary bindings to discard.
-
-The drop_dicts algorithm is based on these observations:
-
- * Given (let d = rhs in e) where d is a DictId,
- matching 'e' will bind e's free variables.
-
- * So we want to keep the binding if one of the needed variables (for
- which we need a binding) is in fv(rhs) but not already in fv(e).
-
- * The "needed variables" are simply the orig_bndrs. Consider
- f :: (Eq a, Show b) => a -> b -> String
- ... SPECIALISE f :: (Show b) => Int -> b -> String ...
- Then orig_bndrs includes the *quantified* dictionaries of the type
- namely (dsb::Show b), but not the one for Eq Int
-
-So we work inside out, applying the above criterion at each step.
-
-
-Note [Simplify rule LHS]
-~~~~~~~~~~~~~~~~~~~~~~~~
-simplOptExpr occurrence-analyses and simplifies the LHS:
-
- (a) Inline any remaining dictionary bindings (which hopefully
- occur just once)
-
- (b) Substitute trivial lets, so that they don't get in the way.
- Note that we substitute the function too; we might
- have this as a LHS: let f71 = M.f Int in f71
-
- (c) Do eta reduction. To see why, consider the fold/build rule,
- which without simplification looked like:
- fold k z (build (/\a. g a)) ==> ...
- This doesn't match unless you do eta reduction on the build argument.
- Similarly for a LHS like
- augment g (build h)
- we do not want to get
- augment (\a. g a) (build h)
- otherwise we don't match when given an argument like
- augment (\a. h a a) (build h)
-
-Note [Unused spec binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- f :: a -> a
- ... SPECIALISE f :: Eq a => a -> a ...
-It's true that this *is* a more specialised type, but the rule
-we get is something like this:
- f_spec d = f
- RULE: f = f_spec d
-Note that the rule is bogus, because it mentions a 'd' that is
-not bound on the LHS! But it's a silly specialisation anyway, because
-the constraint is unused. We could bind 'd' to (error "unused")
-but it seems better to reject the program because it's almost certainly
-a mistake. That's what the isDeadBinder call detects.
-
-Note [No RULES on datacons]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Previously, `RULES` like
-
- "JustNothing" forall x . Just x = Nothing
-
-were allowed. Simon Peyton Jones says this seems to have been a
-mistake, that such rules have never been supported intentionally,
-and that he doesn't know if they can break in horrible ways.
-Furthermore, Ben Gamari and Reid Barton are considering trying to
-detect the presence of "static data" that the simplifier doesn't
-need to traverse at all. Such rules do not play well with that.
-So for now, we ban them altogether as requested by #13290. See also #7398.
-
-
-************************************************************************
-* *
- Desugaring evidence
-* *
-************************************************************************
-
--}
-
-dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
-dsHsWrapper WpHole = return $ \e -> e
-dsHsWrapper (WpTyApp ty) = return $ \e -> App e (Type ty)
-dsHsWrapper (WpEvLam ev) = return $ Lam ev
-dsHsWrapper (WpTyLam tv) = return $ Lam tv
-dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds
- ; return (mkCoreLets bs) }
-dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1
- ; w2 <- dsHsWrapper c2
- ; return (w1 . w2) }
- -- See comments on WpFun in TcEvidence for an explanation of what
- -- the specification of this clause is
-dsHsWrapper (WpFun c1 c2 t1 doc)
- = do { x <- newSysLocalDsNoLP t1
- ; w1 <- dsHsWrapper c1
- ; w2 <- dsHsWrapper c2
- ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
- arg = w1 (Var x)
- ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc
- ; if ok
- then return (\e -> (Lam x (w2 (app e arg))))
- else return id } -- this return is irrelevant
-dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational)
- return $ \e -> mkCastDs e co
-dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm
- ; return (\e -> App e core_tm) }
-
---------------------------------------
-dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
-dsTcEvBinds_s [] = return []
-dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null
- dsTcEvBinds b
-
-dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
-dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
-dsTcEvBinds (EvBinds bs) = dsEvBinds bs
-
-dsEvBinds :: Bag EvBind -> DsM [CoreBind]
-dsEvBinds bs
- = do { ds_bs <- mapBagM dsEvBind bs
- ; return (mk_ev_binds ds_bs) }
-
-mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
--- We do SCC analysis of the evidence bindings, /after/ desugaring
--- them. This is convenient: it means we can use the CoreSyn
--- free-variable functions rather than having to do accurate free vars
--- for EvTerm.
-mk_ev_binds ds_binds
- = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
- where
- edges :: [ Node EvVar (EvVar,CoreExpr) ]
- edges = foldr ((:) . mk_node) [] ds_binds
-
- mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
- mk_node b@(var, rhs)
- = DigraphNode { node_payload = b
- , node_key = var
- , node_dependencies = nonDetEltsUniqSet $
- exprFreeVars rhs `unionVarSet`
- coVarsOfType (varType var) }
- -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
- -- is still deterministic even if the edges are in nondeterministic order
- -- as explained in Note [Deterministic SCC] in Digraph.
-
- ds_scc (AcyclicSCC (v,r)) = NonRec v r
- ds_scc (CyclicSCC prs) = Rec prs
-
-dsEvBind :: EvBind -> DsM (Id, CoreExpr)
-dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
-
-
-{-**********************************************************************
-* *
- Desugaring EvTerms
-* *
-**********************************************************************-}
-
-dsEvTerm :: EvTerm -> DsM CoreExpr
-dsEvTerm (EvExpr e) = return e
-dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
-dsEvTerm (EvFun { et_tvs = tvs, et_given = given
- , et_binds = ev_binds, et_body = wanted_id })
- = do { ds_ev_binds <- dsTcEvBinds ev_binds
- ; return $ (mkLams (tvs ++ given) $
- mkCoreLets ds_ev_binds $
- Var wanted_id) }
-
-
-{-**********************************************************************
-* *
- Desugaring Typeable dictionaries
-* *
-**********************************************************************-}
-
-dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
--- Return a CoreExpr :: Typeable ty
--- This code is tightly coupled to the representation
--- of TypeRep, in base library Data.Typeable.Internals
-dsEvTypeable ty ev
- = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable
- ; let kind = typeKind ty
- Just typeable_data_con
- = tyConSingleDataCon_maybe tyCl -- "Data constructor"
- -- for Typeable
-
- ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a
-
- -- Package up the method as `Typeable` dictionary
- ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] }
-
-type TypeRepExpr = CoreExpr
-
--- | Returns a @CoreExpr :: TypeRep ty@
-ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
-ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)
- = do { mkTrCon <- dsLookupGlobalId mkTrConName
- -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a
- ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName
- ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName
- -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep
-
- ; tc_rep <- tyConRep tc -- :: TyCon
- ; let ks = tyConAppArgs ty
- -- Construct a SomeTypeRep
- toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
- toSomeTypeRep t ev = do
- rep <- getRep ev t
- return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep]
- ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev -- :: TypeRep t
- ; let -- :: [SomeTypeRep]
- kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps
-
- -- Note that we use the kind of the type, not the TyCon from which it
- -- is constructed since the latter may be kind polymorphic whereas the
- -- former we know is not (we checked in the solver).
- ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty)
- , Type ty
- , tc_rep
- , kind_args ]
- -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr
- ; return expr
- }
-
-ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
- | Just (t1,t2) <- splitAppTy_maybe ty
- = do { e1 <- getRep ev1 t1
- ; e2 <- getRep ev2 t2
- ; mkTrApp <- dsLookupGlobalId mkTrAppName
- -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
- -- TypeRep a -> TypeRep b -> TypeRep (a b)
- ; let (k1, k2) = splitFunTy (typeKind t1)
- ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])
- [ e1, e2 ]
- -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr
- ; return expr
- }
-
-ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)
- | Just (t1,t2) <- splitFunTy_maybe ty
- = do { e1 <- getRep ev1 t1
- ; e2 <- getRep ev2 t2
- ; mkTrFun <- dsLookupGlobalId mkTrFunName
- -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2).
- -- TypeRep a -> TypeRep b -> TypeRep (a -> b)
- ; let r1 = getRuntimeRep t1
- r2 = getRuntimeRep t2
- ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2])
- [ e1, e2 ]
- }
-
-ds_ev_typeable ty (EvTypeableTyLit ev)
- = -- See Note [Typeable for Nat and Symbol] in TcInteract
- do { fun <- dsLookupGlobalId tr_fun
- ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol
- ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]
- ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }
- where
- ty_kind = typeKind ty
-
- -- tr_fun is the Name of
- -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a
- -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a
- tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName
- | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName
- | otherwise = panic "dsEvTypeable: unknown type lit kind"
-
-ds_ev_typeable ty ev
- = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)
-
-getRep :: EvTerm -- ^ EvTerm for @Typeable ty@
- -> Type -- ^ The type @ty@
- -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@
- -- namely @typeRep# dict@
--- Remember that
--- typeRep# :: forall k (a::k). Typeable k a -> TypeRep a
-getRep ev ty
- = do { typeable_expr <- dsEvTerm ev
- ; typeRepId <- dsLookupGlobalId typeRepIdName
- ; let ty_args = [typeKind ty, ty]
- ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) }
-
-tyConRep :: TyCon -> DsM CoreExpr
--- Returns CoreExpr :: TyCon
-tyConRep tc
- | Just tc_rep_nm <- tyConRepName_maybe tc
- = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm
- ; return (Var tc_rep_id) }
- | otherwise
- = pprPanic "tyConRep" (ppr tc)
diff --git a/compiler/deSugar/DsBinds.hs-boot b/compiler/deSugar/DsBinds.hs-boot
deleted file mode 100644
index 71c0040039..0000000000
--- a/compiler/deSugar/DsBinds.hs-boot
+++ /dev/null
@@ -1,6 +0,0 @@
-module DsBinds where
-import DsMonad ( DsM )
-import CoreSyn ( CoreExpr )
-import TcEvidence (HsWrapper)
-
-dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs
deleted file mode 100644
index fc5f10eb4b..0000000000
--- a/compiler/deSugar/DsCCall.hs
+++ /dev/null
@@ -1,381 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1994-1998
-
-
-Desugaring foreign calls
--}
-
-{-# LANGUAGE CPP #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-module DsCCall
- ( dsCCall
- , mkFCall
- , unboxArg
- , boxResult
- , resultWrapper
- ) where
-
-#include "HsVersions.h"
-
-
-import GhcPrelude
-
-import CoreSyn
-
-import DsMonad
-import CoreUtils
-import MkCore
-import MkId
-import ForeignCall
-import DataCon
-import DsUtils
-
-import TcType
-import Type
-import Id ( Id )
-import Coercion
-import PrimOp
-import TysPrim
-import TyCon
-import TysWiredIn
-import BasicTypes
-import Literal
-import PrelNames
-import DynFlags
-import Outputable
-import Util
-
-import Data.Maybe
-
-{-
-Desugaring of @ccall@s consists of adding some state manipulation,
-unboxing any boxed primitive arguments and boxing the result if
-desired.
-
-The state stuff just consists of adding in
-@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
-
-The unboxing is straightforward, as all information needed to unbox is
-available from the type. For each boxed-primitive argument, we
-transform:
-\begin{verbatim}
- _ccall_ foo [ r, t1, ... tm ] e1 ... em
- |
- |
- V
- case e1 of { T1# x1# ->
- ...
- case em of { Tm# xm# -> xm#
- ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
- } ... }
-\end{verbatim}
-
-The reboxing of a @_ccall_@ result is a bit tricker: the types don't
-contain information about the state-pairing functions so we have to
-keep a list of \tr{(type, s-p-function)} pairs. We transform as
-follows:
-\begin{verbatim}
- ccall# foo [ r, t1#, ... tm# ] e1# ... em#
- |
- |
- V
- \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
- (StateAnd<r># result# state#) -> (R# result#, realWorld#)
-\end{verbatim}
--}
-
-dsCCall :: CLabelString -- C routine to invoke
- -> [CoreExpr] -- Arguments (desugared)
- -- Precondition: none have levity-polymorphic types
- -> Safety -- Safety of the call
- -> Type -- Type of the result: IO t
- -> DsM CoreExpr -- Result, of type ???
-
-dsCCall lbl args may_gc result_ty
- = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
- (ccall_result_ty, res_wrapper) <- boxResult result_ty
- uniq <- newUnique
- dflags <- getDynFlags
- let
- target = StaticTarget NoSourceText lbl Nothing True
- the_fcall = CCall (CCallSpec target CCallConv may_gc)
- the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
- return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
-
-mkFCall :: DynFlags -> Unique -> ForeignCall
- -> [CoreExpr] -- Args
- -> Type -- Result type
- -> CoreExpr
--- Construct the ccall. The only tricky bit is that the ccall Id should have
--- no free vars, so if any of the arg tys do we must give it a polymorphic type.
--- [I forget *why* it should have no free vars!]
--- For example:
--- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
---
--- Here we build a ccall thus
--- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr))
--- a b s x c
-mkFCall dflags uniq the_fcall val_args res_ty
- = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level
- mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
- where
- arg_tys = map exprType val_args
- body_ty = (mkVisFunTys arg_tys res_ty)
- tyvars = tyCoVarsOfTypeWellScoped body_ty
- ty = mkInvForAllTys tyvars body_ty
- the_fcall_id = mkFCallId dflags uniq the_fcall ty
-
-unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic
- -> DsM (CoreExpr, -- To pass as the actual argument
- CoreExpr -> CoreExpr -- Wrapper to unbox the arg
- )
--- Example: if the arg is e::Int, unboxArg will return
--- (x#::Int#, \W. case x of I# x# -> W)
--- where W is a CoreExpr that probably mentions x#
-
--- always returns a non-levity-polymorphic expression
-
-unboxArg arg
- -- Primitive types: nothing to unbox
- | isPrimitiveType arg_ty
- = return (arg, \body -> body)
-
- -- Recursive newtypes
- | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
- = unboxArg (mkCastDs arg co)
-
- -- Booleans
- | Just tc <- tyConAppTyCon_maybe arg_ty,
- tc `hasKey` boolTyConKey
- = do dflags <- getDynFlags
- prim_arg <- newSysLocalDs intPrimTy
- return (Var prim_arg,
- \ body -> Case (mkWildCase arg arg_ty intPrimTy
- [(DataAlt falseDataCon,[],mkIntLit dflags 0),
- (DataAlt trueDataCon, [],mkIntLit dflags 1)])
- -- In increasing tag order!
- prim_arg
- (exprType body)
- [(DEFAULT,[],body)])
-
- -- Data types with a single constructor, which has a single, primitive-typed arg
- -- This deals with Int, Float etc; also Ptr, ForeignPtr
- | is_product_type && data_con_arity == 1
- = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)
- -- Typechecker ensures this
- do case_bndr <- newSysLocalDs arg_ty
- prim_arg <- newSysLocalDs data_con_arg_ty1
- return (Var prim_arg,
- \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
- )
-
- -- Byte-arrays, both mutable and otherwise; hack warning
- -- We're looking for values of type ByteArray, MutableByteArray
- -- data ByteArray ix = ByteArray ix ix ByteArray#
- -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
- | is_product_type &&
- data_con_arity == 3 &&
- isJust maybe_arg3_tycon &&
- (arg3_tycon == byteArrayPrimTyCon ||
- arg3_tycon == mutableByteArrayPrimTyCon)
- = do case_bndr <- newSysLocalDs arg_ty
- vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
- return (Var arr_cts_var,
- \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
- )
-
- | otherwise
- = do l <- getSrcSpanDs
- pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
- where
- arg_ty = exprType arg
- maybe_product_type = splitDataProductType_maybe arg_ty
- is_product_type = isJust maybe_product_type
- Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
- data_con_arity = dataConSourceArity data_con
- (data_con_arg_ty1 : _) = data_con_arg_tys
-
- (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
- maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3
- Just arg3_tycon = maybe_arg3_tycon
-
-boxResult :: Type
- -> DsM (Type, CoreExpr -> CoreExpr)
-
--- Takes the result of the user-level ccall:
--- either (IO t),
--- or maybe just t for a side-effect-free call
--- Returns a wrapper for the primitive ccall itself, along with the
--- type of the result of the primitive ccall. This result type
--- will be of the form
--- State# RealWorld -> (# State# RealWorld, t' #)
--- where t' is the unwrapped form of t. If t is simply (), then
--- the result type will be
--- State# RealWorld -> (# State# RealWorld #)
-
-boxResult result_ty
- | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
- -- isIOType_maybe handles the case where the type is a
- -- simple wrapping of IO. E.g.
- -- newtype Wrap a = W (IO a)
- -- No coercion necessary because its a non-recursive newtype
- -- (If we wanted to handle a *recursive* newtype too, we'd need
- -- another case, and a coercion.)
- -- The result is IO t, so wrap the result in an IO constructor
- = do { res <- resultWrapper io_res_ty
- ; let extra_result_tys
- = case res of
- (Just ty,_)
- | isUnboxedTupleType ty
- -> let Just ls = tyConAppArgs_maybe ty in tail ls
- _ -> []
-
- return_result state anss
- = mkCoreUbxTup
- (realWorldStatePrimTy : io_res_ty : extra_result_tys)
- (state : anss)
-
- ; (ccall_res_ty, the_alt) <- mk_alt return_result res
-
- ; state_id <- newSysLocalDs realWorldStatePrimTy
- ; let io_data_con = head (tyConDataCons io_tycon)
- toIOCon = dataConWrapId io_data_con
-
- wrap the_call =
- mkApps (Var toIOCon)
- [ Type io_res_ty,
- Lam state_id $
- mkWildCase (App the_call (Var state_id))
- ccall_res_ty
- (coreAltType the_alt)
- [the_alt]
- ]
-
- ; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) }
-
-boxResult result_ty
- = do -- It isn't IO, so do unsafePerformIO
- -- It's not conveniently available, so we inline it
- res <- resultWrapper result_ty
- (ccall_res_ty, the_alt) <- mk_alt return_result res
- let
- wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
- ccall_res_ty
- (coreAltType the_alt)
- [the_alt]
- return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap)
- where
- return_result _ [ans] = ans
- return_result _ _ = panic "return_result: expected single result"
-
-
-mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
- -> (Maybe Type, Expr Var -> Expr Var)
- -> DsM (Type, (AltCon, [Id], Expr Var))
-mk_alt return_result (Nothing, wrap_result)
- = do -- The ccall returns ()
- state_id <- newSysLocalDs realWorldStatePrimTy
- let
- the_rhs = return_result (Var state_id)
- [wrap_result (panic "boxResult")]
-
- ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
- the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs)
-
- return (ccall_res_ty, the_alt)
-
-mk_alt return_result (Just prim_res_ty, wrap_result)
- = -- The ccall returns a non-() value
- ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )
- -- True because resultWrapper ensures it is so
- do { result_id <- newSysLocalDs prim_res_ty
- ; state_id <- newSysLocalDs realWorldStatePrimTy
- ; let the_rhs = return_result (Var state_id)
- [wrap_result (Var result_id)]
- ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
- the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs)
- ; return (ccall_res_ty, the_alt) }
-
-
-resultWrapper :: Type
- -> DsM (Maybe Type, -- Type of the expected result, if any
- CoreExpr -> CoreExpr) -- Wrapper for the result
--- resultWrapper deals with the result *value*
--- E.g. foreign import foo :: Int -> IO T
--- Then resultWrapper deals with marshalling the 'T' part
--- So if resultWrapper ty = (Just ty_rep, marshal)
--- then marshal (e :: ty_rep) :: ty
--- That is, 'marshal' wrape the result returned by the foreign call,
--- of type ty_rep, into the value Haskell expected, of type 'ty'
---
--- Invariant: ty_rep is always a primitive type
--- i.e. (isPrimitiveType ty_rep) is True
-
-resultWrapper result_ty
- -- Base case 1: primitive types
- | isPrimitiveType result_ty
- = return (Just result_ty, \e -> e)
-
- -- Base case 2: the unit type ()
- | Just (tc,_) <- maybe_tc_app
- , tc `hasKey` unitTyConKey
- = return (Nothing, \_ -> Var unitDataConId)
-
- -- Base case 3: the boolean type
- | Just (tc,_) <- maybe_tc_app
- , tc `hasKey` boolTyConKey
- = do { dflags <- getDynFlags
- ; let marshal_bool e
- = mkWildCase e intPrimTy boolTy
- [ (DEFAULT ,[],Var trueDataConId )
- , (LitAlt (mkLitInt dflags 0),[],Var falseDataConId)]
- ; return (Just intPrimTy, marshal_bool) }
-
- -- Newtypes
- | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
- = do { (maybe_ty, wrapper) <- resultWrapper rep_ty
- ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }
-
- -- The type might contain foralls (eg. for dummy type arguments,
- -- referring to 'Ptr a' is legal).
- | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
- = do { (maybe_ty, wrapper) <- resultWrapper rest
- ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }
-
- -- Data types with a single constructor, which has a single arg
- -- This includes types like Ptr and ForeignPtr
- | Just (tycon, tycon_arg_tys) <- maybe_tc_app
- , Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials
- , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument
- = do { dflags <- getDynFlags
- ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
- ; let narrow_wrapper = maybeNarrow dflags tycon
- marshal_con e = Var (dataConWrapId data_con)
- `mkTyApps` tycon_arg_tys
- `App` wrapper (narrow_wrapper e)
- ; return (maybe_ty, marshal_con) }
-
- | otherwise
- = pprPanic "resultWrapper" (ppr result_ty)
- where
- maybe_tc_app = splitTyConApp_maybe result_ty
-
--- When the result of a foreign call is smaller than the word size, we
--- need to sign- or zero-extend the result up to the word size. The C
--- standard appears to say that this is the responsibility of the
--- caller, not the callee.
-
-maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
-maybeNarrow dflags tycon
- | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
- | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
- | tycon `hasKey` int32TyConKey
- && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
-
- | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
- | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
- | tycon `hasKey` word32TyConKey
- && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
- | otherwise = id
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
deleted file mode 100644
index 23d53ce3ca..0000000000
--- a/compiler/deSugar/DsExpr.hs
+++ /dev/null
@@ -1,1201 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Desugaring expressions.
--}
-
-{-# LANGUAGE CPP, MultiWayIf #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
- , dsValBinds, dsLit, dsSyntaxExpr
- , dsHandleMonadicFailure ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import Match
-import MatchLit
-import DsBinds
-import DsGRHSs
-import DsListComp
-import DsUtils
-import DsArrows
-import DsMonad
-import GHC.HsToCore.PmCheck ( checkGuardMatches )
-import Name
-import NameEnv
-import FamInstEnv( topNormaliseType )
-import DsMeta
-import GHC.Hs
-
--- NB: The desugarer, which straddles the source and Core worlds, sometimes
--- needs to see source types
-import TcType
-import TcEvidence
-import TcRnMonad
-import Type
-import CoreSyn
-import CoreUtils
-import MkCore
-
-import DynFlags
-import CostCentre
-import Id
-import MkId
-import Module
-import ConLike
-import DataCon
-import TyCoPpr( pprWithTYPE )
-import TysWiredIn
-import PrelNames
-import BasicTypes
-import Maybes
-import VarEnv
-import SrcLoc
-import Util
-import Bag
-import Outputable
-import PatSyn
-
-import Control.Monad
-
-{-
-************************************************************************
-* *
- dsLocalBinds, dsValBinds
-* *
-************************************************************************
--}
-
-dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body
-dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
- dsValBinds binds body
-dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
-dsLocalBinds _ _ = panic "dsLocalBinds"
-
--------------------------
--- caller sets location
-dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsValBinds (XValBindsLR (NValBinds binds _)) body
- = foldrM ds_val_bind body binds
-dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
-
--------------------------
-dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsIPBinds (IPBinds ev_binds ip_binds) body
- = do { ds_binds <- dsTcEvBinds ev_binds
- ; let inner = mkCoreLets ds_binds body
- -- The dict bindings may not be in
- -- dependency order; hence Rec
- ; foldrM ds_ip_bind inner ip_binds }
- where
- ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
- = do e' <- dsLExpr e
- return (Let (NonRec n e') body)
- ds_ip_bind _ _ = panic "dsIPBinds"
-dsIPBinds (XHsIPBinds nec) _ = noExtCon nec
-
--------------------------
--- caller sets location
-ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
--- Special case for bindings which bind unlifted variables
--- We need to do a case right away, rather than building
--- a tuple and doing selections.
--- Silently ignore INLINE and SPECIALISE pragmas...
-ds_val_bind (NonRecursive, hsbinds) body
- | [L loc bind] <- bagToList hsbinds
- -- Non-recursive, non-overloaded bindings only come in ones
- -- ToDo: in some bizarre case it's conceivable that there
- -- could be dict binds in the 'binds'. (See the notes
- -- below. Then pattern-match would fail. Urk.)
- , isUnliftedHsBind bind
- = putSrcSpanDs loc $
- -- see Note [Strict binds checks] in DsBinds
- if is_polymorphic bind
- then errDsCoreExpr (poly_bind_err bind)
- -- data Ptr a = Ptr Addr#
- -- f x = let p@(Ptr y) = ... in ...
- -- Here the binding for 'p' is polymorphic, but does
- -- not mix with an unlifted binding for 'y'. You should
- -- use a bang pattern. #6078.
-
- else do { when (looksLazyPatBind bind) $
- warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)
- -- Complain about a binding that looks lazy
- -- e.g. let I# y = x in ...
- -- Remember, in checkStrictBinds we are going to do strict
- -- matching, so (for software engineering reasons) we insist
- -- that the strictness is manifest on each binding
- -- However, lone (unboxed) variables are ok
-
-
- ; dsUnliftedBind bind body }
- where
- is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
- = not (null tvs && null evs)
- is_polymorphic _ = False
-
- unlifted_must_be_bang bind
- = hang (text "Pattern bindings containing unlifted types should use" $$
- text "an outermost bang pattern:")
- 2 (ppr bind)
-
- poly_bind_err bind
- = hang (text "You can't mix polymorphic and unlifted bindings:")
- 2 (ppr bind) $$
- text "Probable fix: add a type signature"
-
-ds_val_bind (is_rec, binds) _body
- | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds
- = ASSERT( isRec is_rec )
- errDsCoreExpr $
- hang (text "Recursive bindings for unlifted types aren't allowed:")
- 2 (vcat (map ppr (bagToList binds)))
-
--- Ordinary case for bindings; none should be unlifted
-ds_val_bind (is_rec, binds) body
- = do { MASSERT( isRec is_rec || isSingletonBag binds )
- -- we should never produce a non-recursive list of multiple binds
-
- ; (force_vars,prs) <- dsLHsBinds binds
- ; let body' = foldr seqVar body force_vars
- ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
- case prs of
- [] -> return body
- _ -> return (Let (Rec prs) body') }
- -- Use a Rec regardless of is_rec.
- -- Why? Because it allows the binds to be all
- -- mixed up, which is what happens in one rare case
- -- Namely, for an AbsBind with no tyvars and no dicts,
- -- but which does have dictionary bindings.
- -- See notes with TcSimplify.inferLoop [NO TYVARS]
- -- It turned out that wrapping a Rec here was the easiest solution
- --
- -- NB The previous case dealt with unlifted bindings, so we
- -- only have to deal with lifted ones now; so Rec is ok
-
-------------------
-dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
-dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
- , abs_exports = exports
- , abs_ev_binds = ev_binds
- , abs_binds = lbinds }) body
- = do { let body1 = foldr bind_export body exports
- bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
- ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
- body1 lbinds
- ; ds_binds <- dsTcEvBinds_s ev_binds
- ; return (mkCoreLets ds_binds body2) }
-
-dsUnliftedBind (FunBind { fun_id = L l fun
- , fun_matches = matches
- , fun_ext = co_fn
- , fun_tick = tick }) body
- -- Can't be a bang pattern (that looks like a PatBind)
- -- so must be simply unboxed
- = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
- Nothing matches
- ; MASSERT( null args ) -- Functions aren't lifted
- ; MASSERT( isIdHsWrapper co_fn )
- ; let rhs' = mkOptTickBox tick rhs
- ; return (bindNonRec fun rhs' body) }
-
-dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
- , pat_ext = NPatBindTc _ ty }) body
- = -- let C x# y# = rhs in body
- -- ==> case rhs of C x# y# -> body
- do { rhs <- dsGuarded grhss ty
- ; checkGuardMatches PatBindGuards grhss
- ; let upat = unLoc pat
- eqn = EqnInfo { eqn_pats = [upat],
- eqn_orig = FromSource,
- eqn_rhs = cantFailMatchResult body }
- ; var <- selectMatchVar upat
- ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
- ; return (bindNonRec var rhs result) }
-
-dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
-
-{-
-************************************************************************
-* *
-\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
-* *
-************************************************************************
--}
-
-dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
-
-dsLExpr (L loc e)
- = putSrcSpanDs loc $
- do { core_expr <- dsExpr e
- -- uncomment this check to test the hsExprType function in TcHsSyn
- -- ; MASSERT2( exprType core_expr `eqType` hsExprType e
- -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$
- -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
- ; return core_expr }
-
--- | Variant of 'dsLExpr' that ensures that the result is not levity
--- polymorphic. This should be used when the resulting expression will
--- be an argument to some other function.
--- See Note [Levity polymorphism checking] in DsMonad
--- See Note [Levity polymorphism invariants] in CoreSyn
-dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
-dsLExprNoLP (L loc e)
- = putSrcSpanDs loc $
- do { e' <- dsExpr e
- ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
- ; return e' }
-
-dsExpr :: HsExpr GhcTc -> DsM CoreExpr
-dsExpr (HsPar _ e) = dsLExpr e
-dsExpr (ExprWithTySig _ e _) = dsLExpr e
-dsExpr (HsVar _ (L _ var)) = dsHsVar var
-dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
-dsExpr (HsConLikeOut _ con) = dsConLike con
-dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar"
-dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel"
-
-dsExpr (HsLit _ lit)
- = do { warnAboutOverflowedLit lit
- ; dsLit (convertLit lit) }
-
-dsExpr (HsOverLit _ lit)
- = do { warnAboutOverflowedOverLit lit
- ; dsOverLit lit }
-
-dsExpr hswrap@(XExpr (HsWrap co_fn e))
- = do { e' <- case e of
- HsVar _ (L _ var) -> return $ varToCoreExpr var
- HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc)
- XExpr (HsWrap _ _) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap)
- HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap)
- _ -> dsExpr e
- -- See Note [Detecting forced eta expansion]
- ; wrap' <- dsHsWrapper co_fn
- ; dflags <- getDynFlags
- ; let wrapped_e = wrap' e'
- wrapped_ty = exprType wrapped_e
- ; checkForcedEtaExpansion e (ppr hswrap) wrapped_ty -- See Note [Detecting forced eta expansion]
- -- Pass HsWrap, so that the user can see entire expression with -fprint-typechecker-elaboration
- ; warnAboutIdentities dflags e' wrapped_ty
- ; return wrapped_e }
-
-dsExpr (NegApp _ (L loc
- (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
- neg_expr)
- = do { expr' <- putSrcSpanDs loc $ do
- { warnAboutOverflowedOverLit
- (lit { ol_val = HsIntegral (negateIntegralLit i) })
- ; dsOverLit lit }
- ; dsSyntaxExpr neg_expr [expr'] }
-
-dsExpr (NegApp _ expr neg_expr)
- = do { expr' <- dsLExpr expr
- ; dsSyntaxExpr neg_expr [expr'] }
-
-dsExpr (HsLam _ a_Match)
- = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
-
-dsExpr (HsLamCase _ matches)
- = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
- ; return $ Lam discrim_var matching_code }
-
-dsExpr e@(HsApp _ fun arg)
- = do { fun' <- dsLExpr fun
- ; dsWhenNoErrs (dsLExprNoLP arg)
- (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
-
-dsExpr (HsAppType _ e _)
- -- ignore type arguments here; they're in the wrappers instead at this point
- = dsLExpr e
-
-{-
-Note [Desugaring vars]
-~~~~~~~~~~~~~~~~~~~~~~
-In one situation we can get a *coercion* variable in a HsVar, namely
-the support method for an equality superclass:
- class (a~b) => C a b where ...
- instance (blah) => C (T a) (T b) where ..
-Then we get
- $dfCT :: forall ab. blah => C (T a) (T b)
- $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
-
- $c$p1C :: forall ab. blah => (T a ~ T b)
- $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
-
-That 'g' in the 'in' part is an evidence variable, and when
-converting to core it must become a CO.
-
-Operator sections. At first it looks as if we can convert
-\begin{verbatim}
- (expr op)
-\end{verbatim}
-to
-\begin{verbatim}
- \x -> op expr x
-\end{verbatim}
-
-But no! expr might be a redex, and we can lose laziness badly this
-way. Consider
-\begin{verbatim}
- map (expr op) xs
-\end{verbatim}
-for example. So we convert instead to
-\begin{verbatim}
- let y = expr in \x -> op y x
-\end{verbatim}
-If \tr{expr} is actually just a variable, say, then the simplifier
-will sort it out.
--}
-
-dsExpr e@(OpApp _ e1 op e2)
- = -- for the type of y, we need the type of op's 2nd argument
- do { op' <- dsLExpr op
- ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
- (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
-
-dsExpr (SectionL _ expr op) -- Desugar (e !) to ((!) e)
- = do { op' <- dsLExpr op
- ; dsWhenNoErrs (dsLExprNoLP expr)
- (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
-
--- dsLExpr (SectionR op expr) -- \ x -> op x expr
-dsExpr e@(SectionR _ op expr) = do
- core_op <- dsLExpr op
- -- for the type of x, we need the type of op's 2nd argument
- let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
- -- See comment with SectionL
- y_core <- dsLExpr expr
- dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
- (\[x_id, y_id] -> bindNonRec y_id y_core $
- Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
- core_op [Var x_id, Var y_id]))
-
-dsExpr (ExplicitTuple _ tup_args boxity)
- = do { let go (lam_vars, args) (L _ (Missing ty))
- -- For every missing expression, we need
- -- another lambda in the desugaring.
- = do { lam_var <- newSysLocalDsNoLP ty
- ; return (lam_var : lam_vars, Var lam_var : args) }
- go (lam_vars, args) (L _ (Present _ expr))
- -- Expressions that are present don't generate
- -- lambdas, just arguments.
- = do { core_expr <- dsLExprNoLP expr
- ; return (lam_vars, core_expr : args) }
- go _ _ = panic "dsExpr"
-
- ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
- -- The reverse is because foldM goes left-to-right
- (\(lam_vars, args) -> mkCoreLams lam_vars $
- mkCoreTupBoxity boxity args) }
- -- See Note [Don't flatten tuples from HsSyn] in MkCore
-
-dsExpr (ExplicitSum types alt arity expr)
- = do { dsWhenNoErrs (dsLExprNoLP expr)
- (\core_expr -> mkCoreConApps (sumDataCon alt arity)
- (map (Type . getRuntimeRep) types ++
- map Type types ++
- [core_expr]) ) }
-
-dsExpr (HsPragE _ prag expr) =
- ds_prag_expr prag expr
-
-dsExpr (HsCase _ discrim matches)
- = do { core_discrim <- dsLExpr discrim
- ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
- ; return (bindNonRec discrim_var core_discrim matching_code) }
-
--- Pepe: The binds are in scope in the body but NOT in the binding group
--- This is to avoid silliness in breakpoints
-dsExpr (HsLet _ binds body) = do
- body' <- dsLExpr body
- dsLocalBinds binds body'
-
--- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
--- because the interpretation of `stmts' depends on what sort of thing it is.
---
-dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
-dsExpr (HsDo _ DoExpr (L _ stmts)) = dsDo stmts
-dsExpr (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts
-dsExpr (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts
-dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
-
-dsExpr (HsIf _ fun guard_expr then_expr else_expr)
- = do { pred <- dsLExpr guard_expr
- ; b1 <- dsLExpr then_expr
- ; b2 <- dsLExpr else_expr
- ; case fun of -- See Note [Rebindable if] in Hs.Expr
- (SyntaxExprTc {}) -> dsSyntaxExpr fun [pred, b1, b2]
- NoSyntaxExprTc -> return $ mkIfThenElse pred b1 b2 }
-
-dsExpr (HsMultiIf res_ty alts)
- | null alts
- = mkErrorExpr
-
- | otherwise
- = do { match_result <- liftM (foldr1 combineMatchResults)
- (mapM (dsGRHS IfAlt res_ty) alts)
- ; checkGuardMatches IfAlt (GRHSs noExtField alts (noLoc emptyLocalBinds))
- ; error_expr <- mkErrorExpr
- ; extractMatchResult match_result error_expr }
- where
- mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
- (text "multi-way if")
-
-{-
-\noindent
-\underline{\bf Various data construction things}
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--}
-
-dsExpr (ExplicitList elt_ty wit xs)
- = dsExplicitList elt_ty wit xs
-
-dsExpr (ArithSeq expr witness seq)
- = case witness of
- Nothing -> dsArithSeq expr seq
- Just fl -> do { newArithSeq <- dsArithSeq expr seq
- ; dsSyntaxExpr fl [newArithSeq] }
-
-{-
-Static Pointers
-~~~~~~~~~~~~~~~
-
-See Note [Grand plan for static forms] in StaticPtrTable for an overview.
-
- g = ... static f ...
-==>
- g = ... makeStatic loc f ...
--}
-
-dsExpr (HsStatic _ expr@(L loc _)) = do
- expr_ds <- dsLExprNoLP expr
- let ty = exprType expr_ds
- makeStaticId <- dsLookupGlobalId makeStaticName
-
- dflags <- getDynFlags
- let (line, col) = case loc of
- RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
- , srcLocCol $ realSrcSpanStart r
- )
- _ -> (0, 0)
- srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
- [ Type intTy , Type intTy
- , mkIntExprInt dflags line, mkIntExprInt dflags col
- ]
-
- putSrcSpanDs loc $ return $
- mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
-
-{-
-\noindent
-\underline{\bf Record construction and update}
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For record construction we do this (assuming T has three arguments)
-\begin{verbatim}
- T { op2 = e }
-==>
- let err = /\a -> recConErr a
- T (recConErr t1 "M.hs/230/op1")
- e
- (recConErr t1 "M.hs/230/op3")
-\end{verbatim}
-@recConErr@ then converts its argument string into a proper message
-before printing it as
-\begin{verbatim}
- M.hs, line 230: missing field op1 was evaluated
-\end{verbatim}
-
-We also handle @C{}@ as valid construction syntax for an unlabelled
-constructor @C@, setting all of @C@'s fields to bottom.
--}
-
-dsExpr (RecordCon { rcon_flds = rbinds
- , rcon_ext = RecordConTc { rcon_con_expr = con_expr
- , rcon_con_like = con_like }})
- = do { con_expr' <- dsExpr con_expr
- ; let
- (arg_tys, _) = tcSplitFunTys (exprType con_expr')
- -- A newtype in the corner should be opaque;
- -- hence TcType.tcSplitFunTys
-
- mk_arg (arg_ty, fl)
- = case findField (rec_flds rbinds) (flSelector fl) of
- (rhs:rhss) -> ASSERT( null rhss )
- dsLExprNoLP rhs
- [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
- unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
-
- labels = conLikeFieldLabels con_like
-
- ; con_args <- if null labels
- then mapM unlabelled_bottom arg_tys
- else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
-
- ; return (mkCoreApps con_expr' con_args) }
-
-{-
-Record update is a little harder. Suppose we have the decl:
-\begin{verbatim}
- data T = T1 {op1, op2, op3 :: Int}
- | T2 {op4, op2 :: Int}
- | T3
-\end{verbatim}
-Then we translate as follows:
-\begin{verbatim}
- r { op2 = e }
-===>
- let op2 = e in
- case r of
- T1 op1 _ op3 -> T1 op1 op2 op3
- T2 op4 _ -> T2 op4 op2
- other -> recUpdError "M.hs/230"
-\end{verbatim}
-It's important that we use the constructor Ids for @T1@, @T2@ etc on the
-RHSs, and do not generate a Core constructor application directly, because the constructor
-might do some argument-evaluation first; and may have to throw away some
-dictionaries.
-
-Note [Update for GADTs]
-~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- data T a b where
- T1 :: { f1 :: a } -> T a Int
-
-Then the wrapper function for T1 has type
- $WT1 :: a -> T a Int
-But if x::T a b, then
- x { f1 = v } :: T a b (not T a Int!)
-So we need to cast (T a Int) to (T a b). Sigh.
-
--}
-
-dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
- , rupd_ext = RecordUpdTc
- { rupd_cons = cons_to_upd
- , rupd_in_tys = in_inst_tys
- , rupd_out_tys = out_inst_tys
- , rupd_wrap = dict_req_wrap }} )
- | null fields
- = dsLExpr record_expr
- | otherwise
- = ASSERT2( notNull cons_to_upd, ppr expr )
-
- do { record_expr' <- dsLExpr record_expr
- ; field_binds' <- mapM ds_field fields
- ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
- upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
-
- -- It's important to generate the match with matchWrapper,
- -- and the right hand sides with applications of the wrapper Id
- -- so that everything works when we are doing fancy unboxing on the
- -- constructor arguments.
- ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
- ; ([discrim_var], matching_code)
- <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates]
- (MG { mg_alts = noLoc alts
- , mg_ext = MatchGroupTc [in_ty] out_ty
- , mg_origin = FromSource })
- -- FromSource is not strictly right, but we
- -- want incomplete pattern-match warnings
-
- ; return (add_field_binds field_binds' $
- bindNonRec discrim_var record_expr' matching_code) }
- where
- ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
- -- Clone the Id in the HsRecField, because its Name is that
- -- of the record selector, and we must not make that a local binder
- -- else we shadow other uses of the record selector
- -- Hence 'lcl_id'. Cf #2735
- ds_field (L _ rec_field)
- = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
- ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
- ; lcl_id <- newSysLocalDs (idType fld_id)
- ; return (idName fld_id, lcl_id, rhs) }
-
- add_field_binds [] expr = expr
- add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
-
- -- Awkwardly, for families, the match goes
- -- from instance type to family type
- (in_ty, out_ty) =
- case (head cons_to_upd) of
- RealDataCon data_con ->
- let tycon = dataConTyCon data_con in
- (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
- PatSynCon pat_syn ->
- ( patSynInstResTy pat_syn in_inst_tys
- , patSynInstResTy pat_syn out_inst_tys)
- mk_alt upd_fld_env con
- = do { let (univ_tvs, ex_tvs, eq_spec,
- prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
- user_tvs =
- case con of
- RealDataCon data_con -> dataConUserTyVars data_con
- PatSynCon _ -> univ_tvs ++ ex_tvs
- -- The order here is because of the order in `TcPatSyn`.
- in_subst = zipTvSubst univ_tvs in_inst_tys
- out_subst = zipTvSubst univ_tvs out_inst_tys
-
- -- I'm not bothering to clone the ex_tvs
- ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))
- ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)
- ; arg_ids <- newSysLocalsDs (substTysUnchecked in_subst arg_tys)
- ; let field_labels = conLikeFieldLabels con
- val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
- field_labels arg_ids
- mk_val_arg fl pat_arg_id
- = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
-
- inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con)
- -- Reconstruct with the WrapId so that unpacking happens
- wrap = mkWpEvVarApps theta_vars <.>
- dict_req_wrap <.>
- mkWpTyApps [ lookupTyVar out_subst tv
- `orElse` mkTyVarTy tv
- | tv <- user_tvs
- , not (tv `elemVarEnv` wrap_subst) ]
- -- Be sure to use user_tvs (which may be ordered
- -- differently than `univ_tvs ++ ex_tvs) above.
- -- See Note [DataCon user type variable binders]
- -- in DataCon.
- rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args
-
- -- Tediously wrap the application in a cast
- -- Note [Update for GADTs]
- wrapped_rhs =
- case con of
- RealDataCon data_con ->
- let
- wrap_co =
- mkTcTyConAppCo Nominal
- (dataConTyCon data_con)
- [ lookup tv ty
- | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
- lookup univ_tv ty =
- case lookupVarEnv wrap_subst univ_tv of
- Just co' -> co'
- Nothing -> mkTcReflCo Nominal ty
- in if null eq_spec
- then rhs
- else mkLHsWrap (mkWpCastN wrap_co) rhs
- -- eq_spec is always null for a PatSynCon
- PatSynCon _ -> rhs
-
- wrap_subst =
- mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
- | (spec, eq_var) <- eq_spec `zip` eqs_vars
- , let tv = eqSpecTyVar spec ]
-
- req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
-
- pat = noLoc $ ConPatOut { pat_con = noLoc con
- , pat_tvs = ex_tvs
- , pat_dicts = eqs_vars ++ theta_vars
- , pat_binds = emptyTcEvBinds
- , pat_args = PrefixCon $ map nlVarPat arg_ids
- , pat_arg_tys = in_inst_tys
- , pat_wrap = req_wrap }
- ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
-
-{- Note [Scrutinee in Record updates]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider #17783:
-
- data PartialRec = No
- | Yes { a :: Int, b :: Bool }
- update No = No
- update r@(Yes {}) = r { b = False }
-
-In the context of pattern-match checking, the occurrence of @r@ in
-@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by
-the following desugaring:
-
- r { b = False } ==> case r of Yes a b -> Yes a False
-
-Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
--}
-
--- Here is where we desugar the Template Haskell brackets and escapes
-
--- Template Haskell stuff
-
-dsExpr (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut"
-dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps
-dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
-
--- Arrow notation extension
-dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd
-
--- Hpc Support
-
-dsExpr (HsTick _ tickish e) = do
- e' <- dsLExpr e
- return (Tick tickish e')
-
--- There is a problem here. The then and else branches
--- have no free variables, so they are open to lifting.
--- We need someway of stopping this.
--- This will make no difference to binary coverage
--- (did you go here: YES or NO), but will effect accurate
--- tick counting.
-
-dsExpr (HsBinTick _ ixT ixF e) = do
- e2 <- dsLExpr e
- do { ASSERT(exprType e2 `eqType` boolTy)
- mkBinaryTickBox ixT ixF e2
- }
-
--- HsSyn constructs that just shouldn't be here:
-dsExpr (HsBracket {}) = panic "dsExpr:HsBracket"
-dsExpr (HsDo {}) = panic "dsExpr:HsDo"
-dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld"
-
-ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
-ds_prag_expr (HsPragSCC _ _ cc) expr = do
- dflags <- getDynFlags
- if gopt Opt_SccProfilingOn dflags
- then do
- mod_name <- getModule
- count <- goptM Opt_ProfCountEntries
- let nm = sl_fs cc
- flavour <- ExprCC <$> getCCIndexM nm
- Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True)
- <$> dsLExpr expr
- else dsLExpr expr
-ds_prag_expr (HsPragCore _ _ _) expr
- = dsLExpr expr
-ds_prag_expr (HsPragTick _ _ _ _) expr = do
- dflags <- getDynFlags
- if gopt Opt_Hpc dflags
- then panic "dsExpr:HsPragTick"
- else dsLExpr expr
-ds_prag_expr (XHsPragE x) _ = noExtCon x
-
-------------------------------
-dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
-dsSyntaxExpr (SyntaxExprTc { syn_expr = expr
- , syn_arg_wraps = arg_wraps
- , syn_res_wrap = res_wrap })
- arg_exprs
- = do { fun <- dsExpr expr
- ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
- ; core_res_wrap <- dsHsWrapper res_wrap
- ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
- ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
- (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
- where
- mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
-dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr"
-
-findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
-findField rbinds sel
- = [hsRecFieldArg fld | L _ fld <- rbinds
- , sel == idName (unLoc $ hsRecFieldId fld) ]
-
-{-
-%--------------------------------------------------------------------
-
-Note [Desugaring explicit lists]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Explicit lists are desugared in a cleverer way to prevent some
-fruitless allocations. Essentially, whenever we see a list literal
-[x_1, ..., x_n] we generate the corresponding expression in terms of
-build:
-
-Explicit lists (literals) are desugared to allow build/foldr fusion when
-beneficial. This is a bit of a trade-off,
-
- * build/foldr fusion can generate far larger code than the corresponding
- cons-chain (e.g. see #11707)
-
- * even when it doesn't produce more code, build can still fail to fuse,
- requiring that the simplifier do more work to bring the expression
- back into cons-chain form; this costs compile time
-
- * when it works, fusion can be a significant win. Allocations are reduced
- by up to 25% in some nofib programs. Specifically,
-
- Program Size Allocs Runtime CompTime
- rewrite +0.0% -26.3% 0.02 -1.8%
- ansi -0.3% -13.8% 0.00 +0.0%
- lift +0.0% -8.7% 0.00 -2.3%
-
-At the moment we use a simple heuristic to determine whether build will be
-fruitful: for small lists we assume the benefits of fusion will be worthwhile;
-for long lists we assume that the benefits will be outweighted by the cost of
-code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
-won't work at all if rewrite rules are disabled, so we don't use the build-based
-desugaring in this case.
-
-We used to have a more complex heuristic which would try to break the list into
-"static" and "dynamic" parts and only build-desugar the dynamic part.
-Unfortunately, determining "static-ness" reliably is a bit tricky and the
-heuristic at times produced surprising behavior (see #11710) so it was dropped.
--}
-
-{- | The longest list length which we will desugar using @build@.
-
-This is essentially a magic number and its setting is unfortunate rather
-arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
-is to avoid deforesting large static data into large(r) code. Ideally we'd
-want a smaller threshold with larger consumers and vice-versa, but we have no
-way of knowing what will be consuming our list in the desugaring impossible to
-set generally correctly.
-
-The effect of reducing this number will be that 'build' fusion is applied
-less often. From a runtime performance perspective, applying 'build' more
-liberally on "moderately" sized lists should rarely hurt and will often it can
-only expose further optimization opportunities; if no fusion is possible it will
-eventually get rule-rewritten back to a list). We do, however, pay in compile
-time.
--}
-maxBuildLength :: Int
-maxBuildLength = 32
-
-dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc]
- -> DsM CoreExpr
--- See Note [Desugaring explicit lists]
-dsExplicitList elt_ty Nothing xs
- = do { dflags <- getDynFlags
- ; xs' <- mapM dsLExprNoLP xs
- ; if xs' `lengthExceeds` maxBuildLength
- -- Don't generate builds if the list is very long.
- || null xs'
- -- Don't generate builds when the [] constructor will do
- || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
- -- Don't generate a build if there are no rules to eliminate it!
- -- See Note [Desugaring RULE left hand sides] in Desugar
- then return $ mkListExpr elt_ty xs'
- else mkBuildExpr elt_ty (mk_build_list xs') }
- where
- mk_build_list xs' (cons, _) (nil, _)
- = return (foldr (App . App (Var cons)) (Var nil) xs')
-
-dsExplicitList elt_ty (Just fln) xs
- = do { list <- dsExplicitList elt_ty Nothing xs
- ; dflags <- getDynFlags
- ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
-
-dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
-dsArithSeq expr (From from)
- = App <$> dsExpr expr <*> dsLExprNoLP from
-dsArithSeq expr (FromTo from to)
- = do dflags <- getDynFlags
- warnAboutEmptyEnumerations dflags from Nothing to
- expr' <- dsExpr expr
- from' <- dsLExprNoLP from
- to' <- dsLExprNoLP to
- return $ mkApps expr' [from', to']
-dsArithSeq expr (FromThen from thn)
- = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]
-dsArithSeq expr (FromThenTo from thn to)
- = do dflags <- getDynFlags
- warnAboutEmptyEnumerations dflags from (Just thn) to
- expr' <- dsExpr expr
- from' <- dsLExprNoLP from
- thn' <- dsLExprNoLP thn
- to' <- dsLExprNoLP to
- return $ mkApps expr' [from', thn', to']
-
-{-
-Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
-handled in DsListComp). Basically does the translation given in the
-Haskell 98 report:
--}
-
-dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr
-dsDo stmts
- = goL stmts
- where
- goL [] = panic "dsDo"
- goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
-
- go _ (LastStmt _ body _ _) stmts
- = ASSERT( null stmts ) dsLExpr body
- -- The 'return' op isn't used for 'do' expressions
-
- go _ (BodyStmt _ rhs then_expr _) stmts
- = do { rhs2 <- dsLExpr rhs
- ; warnDiscardedDoBindings rhs (exprType rhs2)
- ; rest <- goL stmts
- ; dsSyntaxExpr then_expr [rhs2, rest] }
-
- go _ (LetStmt _ binds) stmts
- = do { rest <- goL stmts
- ; dsLocalBinds binds rest }
-
- go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts
- = do { body <- goL stmts
- ; rhs' <- dsLExpr rhs
- ; var <- selectSimpleMatchVarL pat
- ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
- res1_ty (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure pat match fail_op
- ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
-
- go _ (ApplicativeStmt body_ty args mb_join) stmts
- = do {
- let
- (pats, rhss) = unzip (map (do_arg . snd) args)
-
- do_arg (ApplicativeArgOne _ pat expr _ fail_op) =
- ((pat, fail_op), dsLExpr expr)
- do_arg (ApplicativeArgMany _ stmts ret pat) =
- ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
- do_arg (XApplicativeArg nec) = noExtCon nec
-
- ; rhss' <- sequence rhss
-
- ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts)
-
- ; let match_args (pat, fail_op) (vs,body)
- = do { var <- selectSimpleMatchVarL pat
- ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
- body_ty (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure pat match fail_op
- ; return (var:vs, match_code)
- }
-
- ; (vars, body) <- foldrM match_args ([],body') pats
- ; let fun' = mkLams vars body
- ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
- ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
- ; case mb_join of
- Nothing -> return expr
- Just join_op -> dsSyntaxExpr join_op [expr] }
-
- go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
- , recS_rec_ids = rec_ids, recS_ret_fn = return_op
- , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
- , recS_ext = RecStmtTc
- { recS_bind_ty = bind_ty
- , recS_rec_rets = rec_rets
- , recS_ret_ty = body_ty} }) stmts
- = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
- where
- new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
- mfix_app bind_op
- noSyntaxExpr -- Tuple cannot fail
-
- tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
- tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
- rec_tup_pats = map nlVarPat tup_ids
- later_pats = rec_tup_pats
- rets = map noLoc rec_rets
- mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
- mfix_arg = noLoc $ HsLam noExtField
- (MG { mg_alts = noLoc [mkSimpleMatch
- LambdaExpr
- [mfix_pat] body]
- , mg_ext = MatchGroupTc [tup_ty] body_ty
- , mg_origin = Generated })
- mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
- body = noLoc $ HsDo body_ty
- DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
- ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
- ret_stmt = noLoc $ mkLastStmt ret_app
- -- This LastStmt will be desugared with dsDo,
- -- which ignores the return_op in the LastStmt,
- -- so we must apply the return_op explicitly
-
- go _ (ParStmt {}) _ = panic "dsDo ParStmt"
- go _ (TransStmt {}) _ = panic "dsDo TransStmt"
- go _ (XStmtLR nec) _ = noExtCon nec
-
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
- -- In a do expression, pattern-match failure just calls
- -- the monadic 'fail' rather than throwing an exception
-dsHandleMonadicFailure pat match fail_op
- | matchCanFail match
- = do { dflags <- getDynFlags
- ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
- ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
- ; extractMatchResult match fail_expr }
- | otherwise
- = extractMatchResult match (error "It can't fail")
-
-mk_fail_msg :: DynFlags -> Located e -> String
-mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
- showPpr dflags (getLoc pat)
-
-{-
-************************************************************************
-* *
- Desugaring Variables
-* *
-************************************************************************
--}
-
-dsHsVar :: Id -> DsM CoreExpr
-dsHsVar var
- -- See Wrinkle in Note [Detecting forced eta expansion]
- = ASSERT2(null (badUseOfLevPolyPrimop var ty), ppr var $$ ppr ty)
- return (varToCoreExpr var) -- See Note [Desugaring vars]
-
- where
- ty = idType var
-
-dsConLike :: ConLike -> DsM CoreExpr
-dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc)
-dsConLike (PatSynCon ps) = return $ case patSynBuilder ps of
- Just (id, add_void)
- | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)
- | otherwise -> Var id
- _ -> pprPanic "dsConLike" (ppr ps)
-
-{-
-************************************************************************
-* *
-\subsection{Errors and contexts}
-* *
-************************************************************************
--}
-
--- Warn about certain types of values discarded in monadic bindings (#3263)
-warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
-warnDiscardedDoBindings rhs rhs_ty
- | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
- = do { warn_unused <- woptM Opt_WarnUnusedDoBind
- ; warn_wrong <- woptM Opt_WarnWrongDoBind
- ; when (warn_unused || warn_wrong) $
- do { fam_inst_envs <- dsGetFamInstEnvs
- ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
-
- -- Warn about discarding non-() things in 'monadic' binding
- ; if warn_unused && not (isUnitTy norm_elt_ty)
- then warnDs (Reason Opt_WarnUnusedDoBind)
- (badMonadBind rhs elt_ty)
- else
-
- -- Warn about discarding m a things in 'monadic' binding of the same type,
- -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
- when warn_wrong $
- do { case tcSplitAppTy_maybe norm_elt_ty of
- Just (elt_m_ty, _)
- | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
- -> warnDs (Reason Opt_WarnWrongDoBind)
- (badMonadBind rhs elt_ty)
- _ -> return () } } }
-
- | otherwise -- RHS does have type of form (m ty), which is weird
- = return () -- but at least this warning is irrelevant
-
-badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
-badMonadBind rhs elt_ty
- = vcat [ hang (text "A do-notation statement discarded a result of type")
- 2 (quotes (ppr elt_ty))
- , hang (text "Suppress this warning by saying")
- 2 (quotes $ text "_ <-" <+> ppr rhs)
- ]
-
-{-
-************************************************************************
-* *
- Forced eta expansion and levity polymorphism
-* *
-************************************************************************
-
-Note [Detecting forced eta expansion]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We cannot have levity polymorphic function arguments. See
-Note [Levity polymorphism invariants] in CoreSyn. But we *can* have
-functions that take levity polymorphic arguments, as long as these
-functions are eta-reduced. (See #12708 for an example.)
-
-However, we absolutely cannot do this for functions that have no
-binding (i.e., say True to Id.hasNoBinding), like primops and unboxed
-tuple constructors. These get eta-expanded in CorePrep.maybeSaturate.
-
-Detecting when this is about to happen is a bit tricky, though. When
-the desugarer is looking at the Id itself (let's be concrete and
-suppose we have (#,#)), we don't know whether it will be levity
-polymorphic. So the right spot seems to be to look after the Id has
-been applied to its type arguments. To make the algorithm efficient,
-it's important to be able to spot ((#,#) @a @b @c @d) without looking
-past all the type arguments. We thus require that
- * The body of an HsWrap is not an HsWrap, nor an HsPar.
-This invariant is checked in dsExpr.
-With that representation invariant, we simply look inside every HsWrap
-to see if its body is an HsVar whose Id hasNoBinding. Then, we look
-at the wrapped type. If it has any levity polymorphic arguments, reject.
-
-Interestingly, this approach does not look to see whether the Id in
-question will be eta expanded. The logic is this:
- * Either the Id in question is saturated or not.
- * If it is, then it surely can't have levity polymorphic arguments.
- If its wrapped type contains levity polymorphic arguments, reject.
- * If it's not, then it can't be eta expanded with levity polymorphic
- argument. If its wrapped type contains levity polymorphic arguments, reject.
-So, either way, we're good to reject.
-
-Wrinkle
-~~~~~~~
-Currently, all levity-polymorphic Ids are wrapped in HsWrap.
-
-However, this is not set in stone, in the future we might make
-instantiation more lazy. (See "Visible type application", ESOP '16.)
-If we spot a levity-polymorphic hasNoBinding Id without a wrapper,
-then that is surely a problem. In this case, we raise an assertion failure.
-This failure can be changed to a call to `levPolyPrimopErr` in the future,
-if we decide to change instantiation.
-
-We can just check HsVar and HsConLikeOut for RealDataCon, since
-we don't have levity-polymorphic pattern synonyms. (This might change
-in the future.)
--}
-
--- | Takes an expression and its instantiated type. If the expression is an
--- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments,
--- issue an error. See Note [Detecting forced eta expansion]
-checkForcedEtaExpansion :: HsExpr GhcTc -> SDoc -> Type -> DsM ()
-checkForcedEtaExpansion expr expr_doc ty
- | Just var <- case expr of
- HsVar _ (L _ var) -> Just var
- HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
- _ -> Nothing
- , let bad_tys = badUseOfLevPolyPrimop var ty
- , not (null bad_tys)
- = levPolyPrimopErr expr_doc ty bad_tys
-checkForcedEtaExpansion _ _ _ = return ()
-
--- | Is this a hasNoBinding Id with a levity-polymorphic type?
--- Returns the arguments that are levity polymorphic if they are bad;
--- or an empty list otherwise
--- See Note [Detecting forced eta expansion]
-badUseOfLevPolyPrimop :: Id -> Type -> [Type]
-badUseOfLevPolyPrimop id ty
- | hasNoBinding id
- = filter isTypeLevPoly arg_tys
- | otherwise
- = []
- where
- (binders, _) = splitPiTys ty
- arg_tys = mapMaybe binderRelevantType_maybe binders
-
-levPolyPrimopErr :: SDoc -> Type -> [Type] -> DsM ()
-levPolyPrimopErr expr_doc ty bad_tys
- = errDs $ vcat
- [ hang (text "Cannot use function with levity-polymorphic arguments:")
- 2 (expr_doc <+> dcolon <+> pprWithTYPE ty)
- , sdocWithDynFlags $ \dflags ->
- if not (gopt Opt_PrintTypecheckerElaboration dflags) then vcat
- [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"
- , text "are eta-expanded internally because they must occur fully saturated."
- , text "Use -fprint-typechecker-elaboration to display the full expression.)"
- ] else empty
- , hang (text "Levity-polymorphic arguments:")
- 2 $ vcat $ map
- (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))
- bad_tys
- ]
diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot
deleted file mode 100644
index e3eed65538..0000000000
--- a/compiler/deSugar/DsExpr.hs-boot
+++ /dev/null
@@ -1,12 +0,0 @@
-module DsExpr where
-import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )
-import DsMonad ( DsM, MatchResult )
-import CoreSyn ( CoreExpr )
-import GHC.Hs.Extension ( GhcTc)
-
-dsExpr :: HsExpr GhcTc -> DsM CoreExpr
-dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
-dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
-dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
-
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs
deleted file mode 100644
index 5c2b1a8a22..0000000000
--- a/compiler/deSugar/DsForeign.hs
+++ /dev/null
@@ -1,820 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1998
-
-
-Desugaring foreign declarations (see also DsCCall).
--}
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module DsForeign ( dsForeigns ) where
-
-#include "HsVersions.h"
-import GhcPrelude
-
-import TcRnMonad -- temp
-
-import CoreSyn
-
-import DsCCall
-import DsMonad
-
-import GHC.Hs
-import DataCon
-import CoreUnfold
-import Id
-import Literal
-import Module
-import Name
-import Type
-import GHC.Types.RepType
-import TyCon
-import Coercion
-import TcEnv
-import TcType
-
-import GHC.Cmm.Expr
-import GHC.Cmm.Utils
-import HscTypes
-import ForeignCall
-import TysWiredIn
-import TysPrim
-import PrelNames
-import BasicTypes
-import SrcLoc
-import Outputable
-import FastString
-import DynFlags
-import GHC.Platform
-import OrdList
-import Util
-import Hooks
-import Encoding
-
-import Data.Maybe
-import Data.List
-
-{-
-Desugaring of @foreign@ declarations is naturally split up into
-parts, an @import@ and an @export@ part. A @foreign import@
-declaration
-\begin{verbatim}
- foreign import cc nm f :: prim_args -> IO prim_res
-\end{verbatim}
-is the same as
-\begin{verbatim}
- f :: prim_args -> IO prim_res
- f a1 ... an = _ccall_ nm cc a1 ... an
-\end{verbatim}
-so we reuse the desugaring code in @DsCCall@ to deal with these.
--}
-
-type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
- -- the occurrence analyser will sort it all out
-
-dsForeigns :: [LForeignDecl GhcTc]
- -> DsM (ForeignStubs, OrdList Binding)
-dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)
-
-dsForeigns' :: [LForeignDecl GhcTc]
- -> DsM (ForeignStubs, OrdList Binding)
-dsForeigns' []
- = return (NoStubs, nilOL)
-dsForeigns' fos = do
- fives <- mapM do_ldecl fos
- let
- (hs, cs, idss, bindss) = unzip4 fives
- fe_ids = concat idss
- fe_init_code = map foreignExportInitialiser fe_ids
- --
- return (ForeignStubs
- (vcat hs)
- (vcat cs $$ vcat fe_init_code),
- foldr (appOL . toOL) nilOL bindss)
- where
- do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
-
- do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
- traceIf (text "fi start" <+> ppr id)
- let id' = unLoc id
- (bs, h, c) <- dsFImport id' co spec
- traceIf (text "fi end" <+> ppr id)
- return (h, c, [], bs)
-
- do_decl (ForeignExport { fd_name = L _ id
- , fd_e_ext = co
- , fd_fe = CExport
- (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
- (h, c, _, _) <- dsFExport id co ext_nm cconv False
- return (h, c, [id], [])
- do_decl (XForeignDecl nec) = noExtCon nec
-
-{-
-************************************************************************
-* *
-\subsection{Foreign import}
-* *
-************************************************************************
-
-Desugaring foreign imports is just the matter of creating a binding
-that on its RHS unboxes its arguments, performs the external call
-(using the @CCallOp@ primop), before boxing the result up and returning it.
-
-However, we create a worker/wrapper pair, thus:
-
- foreign import f :: Int -> IO Int
-==>
- f x = IO ( \s -> case x of { I# x# ->
- case fw s x# of { (# s1, y# #) ->
- (# s1, I# y# #)}})
-
- fw s x# = ccall f s x#
-
-The strictness/CPR analyser won't do this automatically because it doesn't look
-inside returned tuples; but inlining this wrapper is a Really Good Idea
-because it exposes the boxing to the call site.
--}
-
-dsFImport :: Id
- -> Coercion
- -> ForeignImport
- -> DsM ([Binding], SDoc, SDoc)
-dsFImport id co (CImport cconv safety mHeader spec _) =
- dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
-
-dsCImport :: Id
- -> Coercion
- -> CImportSpec
- -> CCallConv
- -> Safety
- -> Maybe Header
- -> DsM ([Binding], SDoc, SDoc)
-dsCImport id co (CLabel cid) cconv _ _ = do
- dflags <- getDynFlags
- let ty = coercionLKind co
- fod = case tyConAppTyCon_maybe (dropForAlls ty) of
- Just tycon
- | tyConUnique tycon == funPtrTyConKey ->
- IsFunction
- _ -> IsData
- (resTy, foRhs) <- resultWrapper ty
- ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
- let
- rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
- rhs' = Cast rhs co
- stdcall_info = fun_type_arg_stdcall_info dflags cconv ty
- in
- return ([(id, rhs')], empty, empty)
-
-dsCImport id co (CFunction target) cconv@PrimCallConv safety _
- = dsPrimCall id co (CCall (CCallSpec target cconv safety))
-dsCImport id co (CFunction target) cconv safety mHeader
- = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
-dsCImport id co CWrapper cconv _ _
- = dsFExportDynamic id co cconv
-
--- For stdcall labels, if the type was a FunPtr or newtype thereof,
--- then we need to calculate the size of the arguments in order to add
--- the @n suffix to the label.
-fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
-fun_type_arg_stdcall_info dflags StdCallConv ty
- | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
- tyConUnique tc == funPtrTyConKey
- = let
- (bndrs, _) = tcSplitPiTys arg_ty
- fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs
- in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)
-fun_type_arg_stdcall_info _ _other_conv _
- = Nothing
-
-{-
-************************************************************************
-* *
-\subsection{Foreign calls}
-* *
-************************************************************************
--}
-
-dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
- -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
-dsFCall fn_id co fcall mDeclHeader = do
- let
- ty = coercionLKind co
- (tv_bndrs, rho) = tcSplitForAllVarBndrs ty
- (arg_tys, io_res_ty) = tcSplitFunTys rho
-
- args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism
- (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
-
- let
- work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
-
- (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
-
- ccall_uniq <- newUnique
- work_uniq <- newUnique
-
- dflags <- getDynFlags
- (fcall', cDoc) <-
- case fcall of
- CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
- CApiConv safety) ->
- do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
- let fcall' = CCall (CCallSpec
- (StaticTarget NoSourceText
- wrapperName mUnitId
- True)
- CApiConv safety)
- c = includes
- $$ fun_proto <+> braces (cRet <> semi)
- includes = vcat [ text "#include \"" <> ftext h
- <> text "\""
- | Header _ h <- nub headers ]
- fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
- cRet
- | isVoidRes = cCall
- | otherwise = text "return" <+> cCall
- cCall = if isFun
- then ppr cName <> parens argVals
- else if null arg_tys
- then ppr cName
- else panic "dsFCall: Unexpected arguments to FFI value import"
- raw_res_ty = case tcSplitIOType_maybe io_res_ty of
- Just (_ioTyCon, res_ty) -> res_ty
- Nothing -> io_res_ty
- isVoidRes = raw_res_ty `eqType` unitTy
- (mHeader, cResType)
- | isVoidRes = (Nothing, text "void")
- | otherwise = toCType raw_res_ty
- pprCconv = ccallConvAttribute CApiConv
- mHeadersArgTypeList
- = [ (header, cType <+> char 'a' <> int n)
- | (t, n) <- zip arg_tys [1..]
- , let (header, cType) = toCType t ]
- (mHeaders, argTypeList) = unzip mHeadersArgTypeList
- argTypes = if null argTypeList
- then text "void"
- else hsep $ punctuate comma argTypeList
- mHeaders' = mDeclHeader : mHeader : mHeaders
- headers = catMaybes mHeaders'
- argVals = hsep $ punctuate comma
- [ char 'a' <> int n
- | (_, n) <- zip arg_tys [1..] ]
- return (fcall', c)
- _ ->
- return (fcall, empty)
- let
- -- Build the worker
- worker_ty = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty)
- tvs = map binderVar tv_bndrs
- the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
- work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
- work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
-
- -- Build the wrapper
- work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
- wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
- wrap_rhs = mkLams (tvs ++ args) wrapper_body
- wrap_rhs' = Cast wrap_rhs co
- fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
- (length args) wrap_rhs'
-
- return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
-
-{-
-************************************************************************
-* *
-\subsection{Primitive calls}
-* *
-************************************************************************
-
-This is for `@foreign import prim@' declarations.
-
-Currently, at the core level we pretend that these primitive calls are
-foreign calls. It may make more sense in future to have them as a distinct
-kind of Id, or perhaps to bundle them with PrimOps since semantically and
-for calling convention they are really prim ops.
--}
-
-dsPrimCall :: Id -> Coercion -> ForeignCall
- -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
-dsPrimCall fn_id co fcall = do
- let
- ty = coercionLKind co
- (tvs, fun_ty) = tcSplitForAllTys ty
- (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
-
- args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism
-
- ccall_uniq <- newUnique
- dflags <- getDynFlags
- let
- call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
- rhs = mkLams tvs (mkLams args call_app)
- rhs' = Cast rhs co
- return ([(fn_id, rhs')], empty, empty)
-
-{-
-************************************************************************
-* *
-\subsection{Foreign export}
-* *
-************************************************************************
-
-The function that does most of the work for `@foreign export@' declarations.
-(see below for the boilerplate code a `@foreign export@' declaration expands
- into.)
-
-For each `@foreign export foo@' in a module M we generate:
-\begin{itemize}
-\item a C function `@foo@', which calls
-\item a Haskell stub `@M.\$ffoo@', which calls
-\end{itemize}
-the user-written Haskell function `@M.foo@'.
--}
-
-dsFExport :: Id -- Either the exported Id,
- -- or the foreign-export-dynamic constructor
- -> Coercion -- Coercion between the Haskell type callable
- -- from C, and its representation type
- -> CLabelString -- The name to export to C land
- -> CCallConv
- -> Bool -- True => foreign export dynamic
- -- so invoke IO action that's hanging off
- -- the first argument's stable pointer
- -> DsM ( SDoc -- contents of Module_stub.h
- , SDoc -- contents of Module_stub.c
- , String -- string describing type to pass to createAdj.
- , Int -- size of args to stub function
- )
-
-dsFExport fn_id co ext_name cconv isDyn = do
- let
- ty = coercionRKind co
- (bndrs, orig_res_ty) = tcSplitPiTys ty
- fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs
- -- We must use tcSplits here, because we want to see
- -- the (IO t) in the corner of the type!
- fe_arg_tys | isDyn = tail fe_arg_tys'
- | otherwise = fe_arg_tys'
-
- -- Look at the result type of the exported function, orig_res_ty
- -- If it's IO t, return (t, True)
- -- If it's plain t, return (t, False)
- (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
- -- The function already returns IO t
- Just (_ioTyCon, res_ty) -> (res_ty, True)
- -- The function returns t
- Nothing -> (orig_res_ty, False)
-
- dflags <- getDynFlags
- return $
- mkFExportCBits dflags ext_name
- (if isDyn then Nothing else Just fn_id)
- fe_arg_tys res_ty is_IO_res_ty cconv
-
-{-
-@foreign import "wrapper"@ (previously "foreign export dynamic") lets
-you dress up Haskell IO actions of some fixed type behind an
-externally callable interface (i.e., as a C function pointer). Useful
-for callbacks and stuff.
-
-\begin{verbatim}
-type Fun = Bool -> Int -> IO Int
-foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
-
--- Haskell-visible constructor, which is generated from the above:
--- SUP: No check for NULL from createAdjustor anymore???
-
-f :: Fun -> IO (FunPtr Fun)
-f cback =
- bindIO (newStablePtr cback)
- (\StablePtr sp# -> IO (\s1# ->
- case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
- (# s2#, a# #) -> (# s2#, A# a# #)))
-
-foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
-
--- and the helper in C: (approximately; see `mkFExportCBits` below)
-
-f_helper(StablePtr s, HsBool b, HsInt i)
-{
- Capability *cap;
- cap = rts_lock();
- rts_evalIO(&cap,
- rts_apply(rts_apply(deRefStablePtr(s),
- rts_mkBool(b)), rts_mkInt(i)));
- rts_unlock(cap);
-}
-\end{verbatim}
--}
-
-dsFExportDynamic :: Id
- -> Coercion
- -> CCallConv
- -> DsM ([Binding], SDoc, SDoc)
-dsFExportDynamic id co0 cconv = do
- mod <- getModule
- dflags <- getDynFlags
- let fe_nm = mkFastString $ zEncodeString
- (moduleStableString mod ++ "$" ++ toCName dflags id)
- -- Construct the label based on the passed id, don't use names
- -- depending on Unique. See #13807 and Note [Unique Determinism].
- cback <- newSysLocalDs arg_ty
- newStablePtrId <- dsLookupGlobalId newStablePtrName
- stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
- let
- stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
- export_ty = mkVisFunTy stable_ptr_ty arg_ty
- bindIOId <- dsLookupGlobalId bindIOName
- stbl_value <- newSysLocalDs stable_ptr_ty
- (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
- let
- {-
- The arguments to the external function which will
- create a little bit of (template) code on the fly
- for allowing the (stable pointed) Haskell closure
- to be entered using an external calling convention
- (stdcall, ccall).
- -}
- adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv)
- , Var stbl_value
- , Lit (LitLabel fe_nm mb_sz_args IsFunction)
- , Lit (mkLitString typestring)
- ]
- -- name of external entry point providing these services.
- -- (probably in the RTS.)
- adjustor = fsLit "createAdjustor"
-
- -- Determine the number of bytes of arguments to the stub function,
- -- so that we can attach the '@N' suffix to its label if it is a
- -- stdcall on Windows.
- mb_sz_args = case cconv of
- StdCallConv -> Just args_size
- _ -> Nothing
-
- ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
- -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
-
- let io_app = mkLams tvs $
- Lam cback $
- mkApps (Var bindIOId)
- [ Type stable_ptr_ty
- , Type res_ty
- , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
- , Lam stbl_value ccall_adj
- ]
-
- fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
- -- Never inline the f.e.d. function, because the litlit
- -- might not be in scope in other modules.
-
- return ([fed], h_code, c_code)
-
- where
- ty = coercionLKind co0
- (tvs,sans_foralls) = tcSplitForAllTys ty
- ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
- Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty
- -- Must have an IO type; hence Just
-
-
-toCName :: DynFlags -> Id -> String
-toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
-
-{-
-*
-
-\subsection{Generating @foreign export@ stubs}
-
-*
-
-For each @foreign export@ function, a C stub function is generated.
-The C stub constructs the application of the exported Haskell function
-using the hugs/ghc rts invocation API.
--}
-
-mkFExportCBits :: DynFlags
- -> FastString
- -> Maybe Id -- Just==static, Nothing==dynamic
- -> [Type]
- -> Type
- -> Bool -- True <=> returns an IO type
- -> CCallConv
- -> (SDoc,
- SDoc,
- String, -- the argument reps
- Int -- total size of arguments
- )
-mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
- = (header_bits, c_bits, type_string,
- sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
- -- NB. the calculation here isn't strictly speaking correct.
- -- We have a primitive Haskell type (eg. Int#, Double#), and
- -- we want to know the size, when passed on the C stack, of
- -- the associated C type (eg. HsInt, HsDouble). We don't have
- -- this information to hand, but we know what GHC's conventions
- -- are for passing around the primitive Haskell types, so we
- -- use that instead. I hope the two coincide --SDM
- )
- where
- -- list the arguments to the C function
- arg_info :: [(SDoc, -- arg name
- SDoc, -- C type
- Type, -- Haskell type
- CmmType)] -- the CmmType
- arg_info = [ let stg_type = showStgType ty in
- (arg_cname n stg_type,
- stg_type,
- ty,
- typeCmmType dflags (getPrimTyOf ty))
- | (ty,n) <- zip arg_htys [1::Int ..] ]
-
- arg_cname n stg_ty
- | libffi = char '*' <> parens (stg_ty <> char '*') <>
- text "args" <> brackets (int (n-1))
- | otherwise = text ('a':show n)
-
- -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
- libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target
-
- type_string
- -- libffi needs to know the result type too:
- | libffi = primTyDescChar dflags res_hty : arg_type_string
- | otherwise = arg_type_string
-
- arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]
- -- just the real args
-
- -- add some auxiliary args; the stable ptr in the wrapper case, and
- -- a slot for the dummy return address in the wrapper + ccall case
- aug_arg_info
- | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
- | otherwise = arg_info
-
- stable_ptr_arg =
- (text "the_stableptr", text "StgStablePtr", undefined,
- typeCmmType dflags (mkStablePtrPrimTy alphaTy))
-
- -- stuff to do with the return type of the C function
- res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes
-
- cResType | res_hty_is_unit = text "void"
- | otherwise = showStgType res_hty
-
- -- when the return type is integral and word-sized or smaller, it
- -- must be assigned as type ffi_arg (#3516). To see what type
- -- libffi is expecting here, take a look in its own testsuite, e.g.
- -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
- ffi_cResType
- | is_ffi_arg_type = text "ffi_arg"
- | otherwise = cResType
- where
- res_ty_key = getUnique (getName (typeTyCon res_hty))
- is_ffi_arg_type = res_ty_key `notElem`
- [floatTyConKey, doubleTyConKey,
- int64TyConKey, word64TyConKey]
-
- -- Now we can cook up the prototype for the exported function.
- pprCconv = ccallConvAttribute cc
-
- header_bits = text "extern" <+> fun_proto <> semi
-
- fun_args
- | null aug_arg_info = text "void"
- | otherwise = hsep $ punctuate comma
- $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
-
- fun_proto
- | libffi
- = text "void" <+> ftext c_nm <>
- parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
- | otherwise
- = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
-
- -- the target which will form the root of what we ask rts_evalIO to run
- the_cfun
- = case maybe_target of
- Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
- Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
-
- cap = text "cap" <> comma
-
- -- the expression we give to rts_evalIO
- expr_to_run
- = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
- where
- appArg acc (arg_cname, _, arg_hty, _)
- = text "rts_apply"
- <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
-
- -- various other bits for inside the fn
- declareResult = text "HaskellObj ret;"
- declareCResult | res_hty_is_unit = empty
- | otherwise = cResType <+> text "cret;"
-
- assignCResult | res_hty_is_unit = empty
- | otherwise =
- text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
-
- -- an extern decl for the fn being called
- extern_decl
- = case maybe_target of
- Nothing -> empty
- Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
-
-
- -- finally, the whole darn thing
- c_bits =
- space $$
- extern_decl $$
- fun_proto $$
- vcat
- [ lbrace
- , text "Capability *cap;"
- , declareResult
- , declareCResult
- , text "cap = rts_lock();"
- -- create the application + perform it.
- , text "rts_evalIO" <> parens (
- char '&' <> cap <>
- text "rts_apply" <> parens (
- cap <>
- text "(HaskellObj)"
- <> ptext (if is_IO_res_ty
- then (sLit "runIO_closure")
- else (sLit "runNonIO_closure"))
- <> comma
- <> expr_to_run
- ) <+> comma
- <> text "&ret"
- ) <> semi
- , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
- <> comma <> text "cap") <> semi
- , assignCResult
- , text "rts_unlock(cap);"
- , ppUnless res_hty_is_unit $
- if libffi
- then char '*' <> parens (ffi_cResType <> char '*') <>
- text "resp = cret;"
- else text "return cret;"
- , rbrace
- ]
-
-
-foreignExportInitialiser :: Id -> SDoc
-foreignExportInitialiser hs_fn =
- -- Initialise foreign exports by registering a stable pointer from an
- -- __attribute__((constructor)) function.
- -- The alternative is to do this from stginit functions generated in
- -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
- -- on binary sizes and link times because the static linker will think that
- -- all modules that are imported directly or indirectly are actually used by
- -- the program.
- -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
- vcat
- [ text "static void stginit_export_" <> ppr hs_fn
- <> text "() __attribute__((constructor));"
- , text "static void stginit_export_" <> ppr hs_fn <> text "()"
- , braces (text "foreignExportStablePtr"
- <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
- <> semi)
- ]
-
-
-mkHObj :: Type -> SDoc
-mkHObj t = text "rts_mk" <> text (showFFIType t)
-
-unpackHObj :: Type -> SDoc
-unpackHObj t = text "rts_get" <> text (showFFIType t)
-
-showStgType :: Type -> SDoc
-showStgType t = text "Hs" <> text (showFFIType t)
-
-showFFIType :: Type -> String
-showFFIType t = getOccString (getName (typeTyCon t))
-
-toCType :: Type -> (Maybe Header, SDoc)
-toCType = f False
- where f voidOK t
- -- First, if we have (Ptr t) of (FunPtr t), then we need to
- -- convert t to a C type and put a * after it. If we don't
- -- know a type for t, then "void" is fine, though.
- | Just (ptr, [t']) <- splitTyConApp_maybe t
- , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
- = case f True t' of
- (mh, cType') ->
- (mh, cType' <> char '*')
- -- Otherwise, if we have a type constructor application, then
- -- see if there is a C type associated with that constructor.
- -- Note that we aren't looking through type synonyms or
- -- anything, as it may be the synonym that is annotated.
- | Just tycon <- tyConAppTyConPicky_maybe t
- , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
- = (mHeader, ftext cType)
- -- If we don't know a C type for this type, then try looking
- -- through one layer of type synonym etc.
- | Just t' <- coreView t
- = f voidOK t'
- -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
- -- (which is marshalled like a Ptr)
- | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t
- = (Nothing, text "const void*")
- | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
- = (Nothing, text "void*")
- -- Otherwise we don't know the C type. If we are allowing
- -- void then return that; otherwise something has gone wrong.
- | voidOK = (Nothing, text "void")
- | otherwise
- = pprPanic "toCType" (ppr t)
-
-typeTyCon :: Type -> TyCon
-typeTyCon ty
- | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
- = tc
- | otherwise
- = pprPanic "DsForeign.typeTyCon" (ppr ty)
-
-insertRetAddr :: DynFlags -> CCallConv
- -> [(SDoc, SDoc, Type, CmmType)]
- -> [(SDoc, SDoc, Type, CmmType)]
-insertRetAddr dflags CCallConv args
- = case platformArch platform of
- ArchX86_64
- | platformOS platform == OSMinGW32 ->
- -- On other Windows x86_64 we insert the return address
- -- after the 4th argument, because this is the point
- -- at which we need to flush a register argument to the stack
- -- (See rts/Adjustor.c for details).
- let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
- -> [(SDoc, SDoc, Type, CmmType)]
- go 4 args = ret_addr_arg dflags : args
- go n (arg:args) = arg : go (n+1) args
- go _ [] = []
- in go 0 args
- | otherwise ->
- -- On other x86_64 platforms we insert the return address
- -- after the 6th integer argument, because this is the point
- -- at which we need to flush a register argument to the stack
- -- (See rts/Adjustor.c for details).
- let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
- -> [(SDoc, SDoc, Type, CmmType)]
- go 6 args = ret_addr_arg dflags : args
- go n (arg@(_,_,_,rep):args)
- | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
- | otherwise = arg : go n args
- go _ [] = []
- in go 0 args
- _ ->
- ret_addr_arg dflags : args
- where platform = targetPlatform dflags
-insertRetAddr _ _ args = args
-
-ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)
-ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,
- typeCmmType dflags addrPrimTy)
-
--- This function returns the primitive type associated with the boxed
--- type argument to a foreign export (eg. Int ==> Int#).
-getPrimTyOf :: Type -> UnaryType
-getPrimTyOf ty
- | isBoolTy rep_ty = intPrimTy
- -- Except for Bool, the types we are interested in have a single constructor
- -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
- | otherwise =
- case splitDataProductType_maybe rep_ty of
- Just (_, _, data_con, [prim_ty]) ->
- ASSERT(dataConSourceArity data_con == 1)
- ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
- prim_ty
- _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
- where
- rep_ty = unwrapType ty
-
--- represent a primitive type as a Char, for building a string that
--- described the foreign function type. The types are size-dependent,
--- e.g. 'W' is a signed 32-bit integer.
-primTyDescChar :: DynFlags -> Type -> Char
-primTyDescChar dflags ty
- | ty `eqType` unitTy = 'v'
- | otherwise
- = case typePrimRep1 (getPrimTyOf ty) of
- IntRep -> signed_word
- WordRep -> unsigned_word
- Int64Rep -> 'L'
- Word64Rep -> 'l'
- AddrRep -> 'p'
- FloatRep -> 'f'
- DoubleRep -> 'd'
- _ -> pprPanic "primTyDescChar" (ppr ty)
- where
- (signed_word, unsigned_word)
- | wORD_SIZE dflags == 4 = ('W','w')
- | wORD_SIZE dflags == 8 = ('L','l')
- | otherwise = panic "primTyDescChar"
diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs
deleted file mode 100644
index a424bd9d7b..0000000000
--- a/compiler/deSugar/DsGRHSs.hs
+++ /dev/null
@@ -1,155 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Matching guarded right-hand-sides (GRHSs)
--}
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ViewPatterns #-}
-
-module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
-import {-# SOURCE #-} Match ( matchSinglePatVar )
-
-import GHC.Hs
-import MkCore
-import CoreSyn
-import CoreUtils (bindNonRec)
-
-import BasicTypes (Origin(FromSource))
-import DynFlags
-import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs)
-import DsMonad
-import DsUtils
-import Type ( Type )
-import Util
-import SrcLoc
-import Outputable
-
-{-
-@dsGuarded@ is used for pattern bindings.
-It desugars:
-\begin{verbatim}
- | g1 -> e1
- ...
- | gn -> en
- where binds
-\end{verbatim}
-producing an expression with a runtime error in the corner if
-necessary. The type argument gives the type of the @ei@.
--}
-
-dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
-dsGuarded grhss rhs_ty = do
- match_result <- dsGRHSs PatBindRhs grhss rhs_ty
- error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
- extractMatchResult match_result error_expr
-
--- In contrast, @dsGRHSs@ produces a @MatchResult@.
-
-dsGRHSs :: HsMatchContext GhcRn
- -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs
- -> Type -- Type of RHS
- -> DsM MatchResult
-dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty
- = ASSERT( notNull grhss )
- do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
- ; let match_result1 = foldr1 combineMatchResults match_results
- match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
- -- NB: nested dsLet inside matchResult
- ; return match_result2 }
-dsGRHSs _ (XGRHSs nec) _ = noExtCon nec
-
-dsGRHS :: HsMatchContext GhcRn -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
- -> DsM MatchResult
-dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs))
- = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
-dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec
-
-{-
-************************************************************************
-* *
-* matchGuard : make a MatchResult from a guarded RHS *
-* *
-************************************************************************
--}
-
-matchGuards :: [GuardStmt GhcTc] -- Guard
- -> HsStmtContext GhcRn -- Context
- -> LHsExpr GhcTc -- RHS
- -> Type -- Type of RHS of guard
- -> DsM MatchResult
-
--- See comments with HsExpr.Stmt re what a BodyStmt means
--- Here we must be in a guard context (not do-expression, nor list-comp)
-
-matchGuards [] _ rhs _
- = do { core_rhs <- dsLExpr rhs
- ; return (cantFailMatchResult core_rhs) }
-
- -- BodyStmts must be guards
- -- Turn an "otherwise" guard is a no-op. This ensures that
- -- you don't get a "non-exhaustive eqns" message when the guards
- -- finish in "otherwise".
- -- NB: The success of this clause depends on the typechecker not
- -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
- -- If it does, you'll get bogus overlap warnings
-matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty
- | Just addTicks <- isTrueLHsExpr e = do
- match_result <- matchGuards stmts ctx rhs rhs_ty
- return (adjustMatchResultDs addTicks match_result)
-matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do
- match_result <- matchGuards stmts ctx rhs rhs_ty
- pred_expr <- dsLExpr expr
- return (mkGuardedMatchResult pred_expr match_result)
-
-matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
- match_result <- matchGuards stmts ctx rhs rhs_ty
- return (adjustMatchResultDs (dsLocalBinds binds) match_result)
- -- NB the dsLet occurs inside the match_result
- -- Reason: dsLet takes the body expression as its argument
- -- so we can't desugar the bindings without the
- -- body expression in hand
-
-matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
- let upat = unLoc pat
- dicts = collectEvVarsPat upat
- match_var <- selectMatchVar upat
-
- dflags <- getDynFlags
- match_result <-
- -- See Note [Type and Term Equality Propagation] in Check
- applyWhen (needToRunPmCheck dflags FromSource)
- -- FromSource might not be accurate, but at worst
- -- we do superfluous calls to the pattern match
- -- oracle.
- (addTyCsDs dicts . addScrutTmCs (Just bind_rhs) [match_var] . addPatTmCs [upat] [match_var])
- (matchGuards stmts ctx rhs rhs_ty)
- core_rhs <- dsLExpr bind_rhs
- match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
- match_result
- pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
-
-matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"
-matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"
-matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
-matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
-matchGuards (ApplicativeStmt {} : _) _ _ _ =
- panic "matchGuards ApplicativeLastStmt"
-matchGuards (XStmtLR nec : _) _ _ _ =
- noExtCon nec
-
-{-
-Should {\em fail} if @e@ returns @D@
-\begin{verbatim}
-f x | p <- e', let C y# = e, f y# = r1
- | otherwise = r2
-\end{verbatim}
--}
diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs
deleted file mode 100644
index 35a71ce8e4..0000000000
--- a/compiler/deSugar/DsListComp.hs
+++ /dev/null
@@ -1,676 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Desugaring list comprehensions, monad comprehensions and array comprehensions
--}
-
-{-# LANGUAGE CPP, NamedFieldPuns #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-module DsListComp ( dsListComp, dsMonadComp ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import {-# SOURCE #-} DsExpr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
-
-import GHC.Hs
-import TcHsSyn
-import CoreSyn
-import MkCore
-
-import DsMonad -- the monadery used in the desugarer
-import DsUtils
-
-import DynFlags
-import CoreUtils
-import Id
-import Type
-import TysWiredIn
-import Match
-import PrelNames
-import SrcLoc
-import Outputable
-import TcType
-import ListSetOps( getNth )
-import Util
-
-{-
-List comprehensions may be desugared in one of two ways: ``ordinary''
-(as you would expect if you read SLPJ's book) and ``with foldr/build
-turned on'' (if you read Gill {\em et al.}'s paper on the subject).
-
-There will be at least one ``qualifier'' in the input.
--}
-
-dsListComp :: [ExprLStmt GhcTc]
- -> Type -- Type of entire list
- -> DsM CoreExpr
-dsListComp lquals res_ty = do
- dflags <- getDynFlags
- let quals = map unLoc lquals
- elt_ty = case tcTyConAppArgs res_ty of
- [elt_ty] -> elt_ty
- _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
-
- if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags
- -- Either rules are switched off, or we are ignoring what there are;
- -- Either way foldr/build won't happen, so use the more efficient
- -- Wadler-style desugaring
- || isParallelComp quals
- -- Foldr-style desugaring can't handle parallel list comprehensions
- then deListComp quals (mkNilExpr elt_ty)
- else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
- -- Foldr/build should be enabled, so desugar
- -- into foldrs and builds
-
- where
- -- We must test for ParStmt anywhere, not just at the head, because an extension
- -- to list comprehensions would be to add brackets to specify the associativity
- -- of qualifier lists. This is really easy to do by adding extra ParStmts into the
- -- mix of possibly a single element in length, so we do this to leave the possibility open
- isParallelComp = any isParallelStmt
-
- isParallelStmt (ParStmt {}) = True
- isParallelStmt _ = False
-
-
--- This function lets you desugar a inner list comprehension and a list of the binders
--- of that comprehension that we need in the outer comprehension into such an expression
--- and the type of the elements that it outputs (tuples of binders)
-dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
-dsInnerListComp (ParStmtBlock _ stmts bndrs _)
- = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
- list_ty = mkListTy bndrs_tuple_type
-
- -- really use original bndrs below!
- ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
-
- ; return (expr, bndrs_tuple_type) }
-dsInnerListComp (XParStmtBlock nec) = noExtCon nec
-
--- This function factors out commonality between the desugaring strategies for GroupStmt.
--- Given such a statement it gives you back an expression representing how to compute the transformed
--- list and the tuple that you need to bind from that list in order to proceed with your desugaring
-dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc)
-dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
- , trS_by = by, trS_using = using }) = do
- let (from_bndrs, to_bndrs) = unzip binderMap
-
- let from_bndrs_tys = map idType from_bndrs
- to_bndrs_tys = map idType to_bndrs
-
- to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
-
- -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
- (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts
- from_bndrs noSyntaxExpr)
-
- -- Work out what arguments should be supplied to that expression: i.e. is an extraction
- -- function required? If so, create that desugared function and add to arguments
- usingExpr' <- dsLExpr using
- usingArgs' <- case by of
- Nothing -> return [expr']
- Just by_e -> do { by_e' <- dsLExpr by_e
- ; lam' <- matchTuple from_bndrs by_e'
- ; return [lam', expr'] }
-
- -- Create an unzip function for the appropriate arity and element types and find "map"
- unzip_stuff' <- mkUnzipBind form from_bndrs_tys
- map_id <- dsLookupGlobalId mapName
-
- -- Generate the expressions to build the grouped list
- let -- First we apply the grouping function to the inner list
- inner_list_expr' = mkApps usingExpr' usingArgs'
- -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
- -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
- -- the "b" to be a tuple of "to" lists!
- -- Then finally we bind the unzip function around that expression
- bound_unzipped_inner_list_expr'
- = case unzip_stuff' of
- Nothing -> inner_list_expr'
- Just (unzip_fn', unzip_rhs') ->
- Let (Rec [(unzip_fn', unzip_rhs')]) $
- mkApps (Var map_id) $
- [ Type (mkListTy from_tup_ty)
- , Type to_bndrs_tup_ty
- , Var unzip_fn'
- , inner_list_expr' ]
-
- dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr'))
- (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using)
-
- -- Build a pattern that ensures the consumer binds into the NEW binders,
- -- which hold lists rather than single values
- let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '!
- return (bound_unzipped_inner_list_expr', pat)
-
-dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"
-
-{-
-************************************************************************
-* *
-\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
-* *
-************************************************************************
-
-Just as in Phil's chapter~7 in SLPJ, using the rules for
-optimally-compiled list comprehensions. This is what Kevin followed
-as well, and I quite happily do the same. The TQ translation scheme
-transforms a list of qualifiers (either boolean expressions or
-generators) into a single expression which implements the list
-comprehension. Because we are generating 2nd-order polymorphic
-lambda-calculus, calls to NIL and CONS must be applied to a type
-argument, as well as their usual value arguments.
-\begin{verbatim}
-TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >>
-
-(Rule C)
-TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
-
-(Rule B)
-TQ << [ e | b , qs ] ++ L >> =
- if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
-
-(Rule A')
-TQ << [ e | p <- L1, qs ] ++ L2 >> =
- letrec
- h = \ u1 ->
- case u1 of
- [] -> TE << L2 >>
- (u2 : u3) ->
- (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2)
- [] (h u3)
- in
- h ( TE << L1 >> )
-
-"h", "u1", "u2", and "u3" are new variables.
-\end{verbatim}
-
-@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@
-is the TE translation scheme. Note that we carry around the @L@ list
-already desugared. @dsListComp@ does the top TE rule mentioned above.
-
-To the above, we add an additional rule to deal with parallel list
-comprehensions. The translation goes roughly as follows:
- [ e | p1 <- e11, let v1 = e12, p2 <- e13
- | q1 <- e21, let v2 = e22, q2 <- e23]
- =>
- [ e | ((x1, .., xn), (y1, ..., ym)) <-
- zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
- [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
-where (x1, .., xn) are the variables bound in p1, v1, p2
- (y1, .., ym) are the variables bound in q1, v2, q2
-
-In the translation below, the ParStmt branch translates each parallel branch
-into a sub-comprehension, and desugars each independently. The resulting lists
-are fed to a zip function, we create a binding for all the variables bound in all
-the comprehensions, and then we hand things off the desugarer for bindings.
-The zip function is generated here a) because it's small, and b) because then we
-don't have to deal with arbitrary limits on the number of zip functions in the
-prelude, nor which library the zip function came from.
-The introduced tuples are Boxed, but only because I couldn't get it to work
-with the Unboxed variety.
--}
-
-deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr
-
-deListComp [] _ = panic "deListComp"
-
-deListComp (LastStmt _ body _ _ : quals) list
- = -- Figure 7.4, SLPJ, p 135, rule C above
- ASSERT( null quals )
- do { core_body <- dsLExpr body
- ; return (mkConsExpr (exprType core_body) core_body list) }
-
- -- Non-last: must be a guard
-deListComp (BodyStmt _ guard _ _ : quals) list = do -- rule B above
- core_guard <- dsLExpr guard
- core_rest <- deListComp quals list
- return (mkIfThenElse core_guard core_rest list)
-
--- [e | let B, qs] = let B in [e | qs]
-deListComp (LetStmt _ binds : quals) list = do
- core_rest <- deListComp quals list
- dsLocalBinds binds core_rest
-
-deListComp (stmt@(TransStmt {}) : quals) list = do
- (inner_list_expr, pat) <- dsTransStmt stmt
- deBindComp pat inner_list_expr quals list
-
-deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above
- core_list1 <- dsLExprNoLP list1
- deBindComp pat core_list1 quals core_list2
-
-deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
- = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
- ; let (exps, qual_tys) = unzip exps_and_qual_tys
-
- ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
-
- -- Deal with [e | pat <- zip l1 .. ln] in example above
- ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
- quals list }
- where
- bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]
-
- -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
- pat = mkBigLHsPatTupId pats
- pats = map mkBigLHsVarPatTupId bndrs_s
-
-deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
-
-deListComp (ApplicativeStmt {} : _) _ =
- panic "deListComp ApplicativeStmt"
-
-deListComp (XStmtLR nec : _) _ =
- noExtCon nec
-
-deBindComp :: OutPat GhcTc
- -> CoreExpr
- -> [ExprStmt GhcTc]
- -> CoreExpr
- -> DsM (Expr Id)
-deBindComp pat core_list1 quals core_list2 = do
- let u3_ty@u1_ty = exprType core_list1 -- two names, same thing
-
- -- u1_ty is a [alpha] type, and u2_ty = alpha
- let u2_ty = hsLPatType pat
-
- let res_ty = exprType core_list2
- h_ty = u1_ty `mkVisFunTy` res_ty
-
- -- no levity polymorphism here, as list comprehensions don't work
- -- with RebindableSyntax. NB: These are *not* monad comps.
- [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
-
- -- the "fail" value ...
- let
- core_fail = App (Var h) (Var u3)
- letrec_body = App (Var h) core_list1
-
- rest_expr <- deListComp quals core_fail
- core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
-
- let
- rhs = Lam u1 $
- Case (Var u1) u1 res_ty
- [(DataAlt nilDataCon, [], core_list2),
- (DataAlt consDataCon, [u2, u3], core_match)]
- -- Increasing order of tag
-
- return (Let (Rec [(h, rhs)]) letrec_body)
-
-{-
-************************************************************************
-* *
-\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
-* *
-************************************************************************
-
-@dfListComp@ are the rules used with foldr/build turned on:
-
-\begin{verbatim}
-TE[ e | ] c n = c e n
-TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n
-TE[ e | p <- l , q ] c n = let
- f = \ x b -> case x of
- p -> TE[ e | q ] c b
- _ -> b
- in
- foldr f n l
-\end{verbatim}
--}
-
-dfListComp :: Id -> Id -- 'c' and 'n'
- -> [ExprStmt GhcTc] -- the rest of the qual's
- -> DsM CoreExpr
-
-dfListComp _ _ [] = panic "dfListComp"
-
-dfListComp c_id n_id (LastStmt _ body _ _ : quals)
- = ASSERT( null quals )
- do { core_body <- dsLExprNoLP body
- ; return (mkApps (Var c_id) [core_body, Var n_id]) }
-
- -- Non-last: must be a guard
-dfListComp c_id n_id (BodyStmt _ guard _ _ : quals) = do
- core_guard <- dsLExpr guard
- core_rest <- dfListComp c_id n_id quals
- return (mkIfThenElse core_guard core_rest (Var n_id))
-
-dfListComp c_id n_id (LetStmt _ binds : quals) = do
- -- new in 1.3, local bindings
- core_rest <- dfListComp c_id n_id quals
- dsLocalBinds binds core_rest
-
-dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
- (inner_list_expr, pat) <- dsTransStmt stmt
- -- Anyway, we bind the newly grouped list via the generic binding function
- dfBindComp c_id n_id (pat, inner_list_expr) quals
-
-dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do
- -- evaluate the two lists
- core_list1 <- dsLExpr list1
-
- -- Do the rest of the work in the generic binding builder
- dfBindComp c_id n_id (pat, core_list1) quals
-
-dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
-dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
-dfListComp _ _ (ApplicativeStmt {} : _) =
- panic "dfListComp ApplicativeStmt"
-dfListComp _ _ (XStmtLR nec : _) =
- noExtCon nec
-
-dfBindComp :: Id -> Id -- 'c' and 'n'
- -> (LPat GhcTc, CoreExpr)
- -> [ExprStmt GhcTc] -- the rest of the qual's
- -> DsM CoreExpr
-dfBindComp c_id n_id (pat, core_list1) quals = do
- -- find the required type
- let x_ty = hsLPatType pat
- let b_ty = idType n_id
-
- -- create some new local id's
- b <- newSysLocalDs b_ty
- x <- newSysLocalDs x_ty
-
- -- build rest of the comprehension
- core_rest <- dfListComp c_id b quals
-
- -- build the pattern match
- core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
- pat core_rest (Var b)
-
- -- now build the outermost foldr, and return
- mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
-
-{-
-************************************************************************
-* *
-\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
-* *
-************************************************************************
--}
-
-mkZipBind :: [Type] -> DsM (Id, CoreExpr)
--- mkZipBind [t1, t2]
--- = (zip, \as1:[t1] as2:[t2]
--- -> case as1 of
--- [] -> []
--- (a1:as'1) -> case as2 of
--- [] -> []
--- (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
-
-mkZipBind elt_tys = do
- ass <- mapM newSysLocalDs elt_list_tys
- as' <- mapM newSysLocalDs elt_tys
- as's <- mapM newSysLocalDs elt_list_tys
-
- zip_fn <- newSysLocalDs zip_fn_ty
-
- let inner_rhs = mkConsExpr elt_tuple_ty
- (mkBigCoreVarTup as')
- (mkVarApps (Var zip_fn) as's)
- zip_body = foldr mk_case inner_rhs (zip3 ass as' as's)
-
- return (zip_fn, mkLams ass zip_body)
- where
- elt_list_tys = map mkListTy elt_tys
- elt_tuple_ty = mkBigCoreTupTy elt_tys
- elt_tuple_list_ty = mkListTy elt_tuple_ty
-
- zip_fn_ty = mkVisFunTys elt_list_tys elt_tuple_list_ty
-
- mk_case (as, a', as') rest
- = Case (Var as) as elt_tuple_list_ty
- [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty),
- (DataAlt consDataCon, [a', as'], rest)]
- -- Increasing order of tag
-
-
-mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
--- mkUnzipBind [t1, t2]
--- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
--- -> case ax of
--- (x1, x2) -> case axs of
--- (xs1, xs2) -> (x1 : xs1, x2 : xs2))
--- ([], [])
--- ys)
---
--- We use foldr here in all cases, even if rules are turned off, because we may as well!
-mkUnzipBind ThenForm _
- = return Nothing -- No unzipping for ThenForm
-mkUnzipBind _ elt_tys
- = do { ax <- newSysLocalDs elt_tuple_ty
- ; axs <- newSysLocalDs elt_list_tuple_ty
- ; ys <- newSysLocalDs elt_tuple_list_ty
- ; xs <- mapM newSysLocalDs elt_tys
- ; xss <- mapM newSysLocalDs elt_list_tys
-
- ; unzip_fn <- newSysLocalDs unzip_fn_ty
-
- ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
-
- ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
- concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
- tupled_concat_expression = mkBigCoreTup concat_expressions
-
- folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
- folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
- folder_body = mkLams [ax, axs] folder_body_outer_case
-
- ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
- ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
- where
- elt_tuple_ty = mkBigCoreTupTy elt_tys
- elt_tuple_list_ty = mkListTy elt_tuple_ty
- elt_list_tys = map mkListTy elt_tys
- elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys
-
- unzip_fn_ty = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty
-
- mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
-
--- Translation for monad comprehensions
-
--- Entry point for monad comprehension desugaring
-dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr
-dsMonadComp stmts = dsMcStmts stmts
-
-dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr
-dsMcStmts [] = panic "dsMcStmts"
-dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
-
----------------
-dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
-
-dsMcStmt (LastStmt _ body _ ret_op) stmts
- = ASSERT( null stmts )
- do { body' <- dsLExpr body
- ; dsSyntaxExpr ret_op [body'] }
-
--- [ .. | let binds, stmts ]
-dsMcStmt (LetStmt _ binds) stmts
- = do { rest <- dsMcStmts stmts
- ; dsLocalBinds binds rest }
-
--- [ .. | a <- m, stmts ]
-dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts
- = do { rhs' <- dsLExpr rhs
- ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
-
--- Apply `guard` to the `exp` expression
---
--- [ .. | exp, stmts ]
---
-dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts
- = do { exp' <- dsLExpr exp
- ; rest <- dsMcStmts stmts
- ; guard_exp' <- dsSyntaxExpr guard_exp [exp']
- ; dsSyntaxExpr then_exp [guard_exp', rest] }
-
--- Group statements desugar like this:
---
--- [| (q, then group by e using f); rest |]
--- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
--- case unzip n_tup of qv' -> [| rest |]
---
--- where variables (v1:t1, ..., vk:tk) are bound by q
--- qv = (v1, ..., vk)
--- qt = (t1, ..., tk)
--- (>>=) :: m2 a -> (a -> m3 b) -> m3 b
--- f :: forall a. (a -> t) -> m1 a -> m2 (n a)
--- n_tup :: n qt
--- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n)
-
-dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
- , trS_by = by, trS_using = using
- , trS_ret = return_op, trS_bind = bind_op
- , trS_ext = n_tup_ty' -- n (a,b,c)
- , trS_fmap = fmap_op, trS_form = form }) stmts_rest
- = do { let (from_bndrs, to_bndrs) = unzip bndrs
-
- ; let from_bndr_tys = map idType from_bndrs -- Types ty
-
-
- -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
- ; expr' <- dsInnerMonadComp stmts from_bndrs return_op
-
- -- Work out what arguments should be supplied to that expression: i.e. is an extraction
- -- function required? If so, create that desugared function and add to arguments
- ; usingExpr' <- dsLExpr using
- ; usingArgs' <- case by of
- Nothing -> return [expr']
- Just by_e -> do { by_e' <- dsLExpr by_e
- ; lam' <- matchTuple from_bndrs by_e'
- ; return [lam', expr'] }
-
- -- Generate the expressions to build the grouped list
- -- Build a pattern that ensures the consumer binds into the NEW binders,
- -- which hold monads rather than single values
- ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs
-
- ; body <- dsMcStmts stmts_rest
- ; n_tup_var' <- newSysLocalDsNoLP n_tup_ty'
- ; tup_n_var' <- newSysLocalDs tup_n_ty'
- ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
- ; us <- newUniqueSupply
- ; let rhs' = mkApps usingExpr' usingArgs'
- body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'
-
- ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }
-
--- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
--- statements, for example:
---
--- [ body | qs1 | qs2 | qs3 ]
--- -> [ body | (bndrs1, (bndrs2, bndrs3))
--- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
---
--- where `mzip` has type
--- mzip :: forall a b. m a -> m b -> m (a,b)
--- NB: we need a polymorphic mzip because we call it several times
-
-dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
- = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty)
- ; mzip_op' <- dsExpr mzip_op
-
- ; let -- The pattern variables
- pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]
- -- Pattern with tuples of variables
- -- [v1,v2,v3] => (v1, (v2, v3))
- pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
- (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
- (mkApps mzip_op' [Type t1, Type t2, e1, e2],
- mkBoxedTupleTy [t1,t2]))
- exps_w_tys
-
- ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
- where
- ds_inner (ParStmtBlock _ stmts bndrs return_op)
- = do { exp <- dsInnerMonadComp stmts bndrs return_op
- ; return (exp, mkBigCoreVarTupTy bndrs) }
- ds_inner (XParStmtBlock nec) = noExtCon nec
-
-dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
-
-
-matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
--- (matchTuple [a,b,c] body)
--- returns the Core term
--- \x. case x of (a,b,c) -> body
-matchTuple ids body
- = do { us <- newUniqueSupply
- ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
- ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
-
--- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
--- desugared `CoreExpr`
-dsMcBindStmt :: LPat GhcTc
- -> CoreExpr -- ^ the desugared rhs of the bind statement
- -> SyntaxExpr GhcTc
- -> SyntaxExpr GhcTc
- -> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T
- -> [ExprLStmt GhcTc]
- -> DsM CoreExpr
-dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
- = do { body <- dsMcStmts stmts
- ; var <- selectSimpleMatchVarL pat
- ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
- res1_ty (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure pat match fail_op
- ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
-
--- Desugar nested monad comprehensions, for example in `then..` constructs
--- dsInnerMonadComp quals [a,b,c] ret_op
--- returns the desugaring of
--- [ (a,b,c) | quals ]
-
-dsInnerMonadComp :: [ExprLStmt GhcTc]
- -> [Id] -- Return a tuple of these variables
- -> SyntaxExpr GhcTc -- The monomorphic "return" operator
- -> DsM CoreExpr
-dsInnerMonadComp stmts bndrs ret_op
- = dsMcStmts (stmts ++
- [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) False ret_op)])
-
-
--- The `unzip` function for `GroupStmt` in a monad comprehensions
---
--- unzip :: m (a,b,..) -> (m a,m b,..)
--- unzip m_tuple = ( liftM selN1 m_tuple
--- , liftM selN2 m_tuple
--- , .. )
---
--- mkMcUnzipM fmap ys [t1, t2]
--- = ( fmap (selN1 :: (t1, t2) -> t1) ys
--- , fmap (selN2 :: (t1, t2) -> t2) ys )
-
-mkMcUnzipM :: TransForm
- -> HsExpr GhcTcId -- fmap
- -> Id -- Of type n (a,b,c)
- -> [Type] -- [a,b,c] (not levity-polymorphic)
- -> DsM CoreExpr -- Of type (n a, n b, n c)
-mkMcUnzipM ThenForm _ ys _
- = return (Var ys) -- No unzipping to do
-
-mkMcUnzipM _ fmap_op ys elt_tys
- = do { fmap_op' <- dsExpr fmap_op
- ; xs <- mapM newSysLocalDs elt_tys
- ; let tup_ty = mkBigCoreTupTy elt_tys
- ; tup_xs <- newSysLocalDs tup_ty
-
- ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b
- [ Type tup_ty, Type (getNth elt_tys i)
- , mk_sel i, Var ys]
-
- mk_sel n = Lam tup_xs $
- mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)
-
- ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
deleted file mode 100644
index 5473682a40..0000000000
--- a/compiler/deSugar/DsMeta.hs
+++ /dev/null
@@ -1,2958 +0,0 @@
-{-# LANGUAGE CPP, TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 2006
---
--- The purpose of this module is to transform an HsExpr into a CoreExpr which
--- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
--- input HsExpr. We do this in the DsM monad, which supplies access to
--- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
---
--- It also defines a bunch of knownKeyNames, in the same way as is done
--- in prelude/PrelNames. It's much more convenient to do it here, because
--- otherwise we have to recompile PrelNames whenever we add a Name, which is
--- a Royal Pain (triggers other recompilation).
------------------------------------------------------------------------------
-
-module DsMeta( dsBracket ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import {-# SOURCE #-} DsExpr ( dsExpr )
-
-import MatchLit
-import DsMonad
-
-import qualified Language.Haskell.TH as TH
-
-import GHC.Hs
-import PrelNames
--- To avoid clashes with DsMeta.varName we must make a local alias for
--- OccName.varName we do this by removing varName from the import of
--- OccName above, making a qualified instance of OccName and using
--- OccNameAlias.varName where varName ws previously used in this file.
-import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
-
-import Module
-import Id
-import Name hiding( isVarOcc, isTcOcc, varName, tcName )
-import THNames
-import NameEnv
-import TcType
-import TyCon
-import TysWiredIn
-import CoreSyn
-import MkCore
-import CoreUtils
-import SrcLoc
-import Unique
-import BasicTypes
-import Outputable
-import Bag
-import DynFlags
-import FastString
-import ForeignCall
-import Util
-import Maybes
-import MonadUtils
-import TcEvidence
-import Control.Monad.Trans.Reader
-import Control.Monad.Trans.Class
-import Class
-import HscTypes ( MonadThings )
-import DataCon
-import Var
-import DsBinds
-
-import GHC.TypeLits
-import Data.Kind (Constraint)
-
-import Data.ByteString ( unpack )
-import Control.Monad
-import Data.List
-
-data MetaWrappers = MetaWrappers {
- -- Applies its argument to a type argument `m` and dictionary `Quote m`
- quoteWrapper :: CoreExpr -> CoreExpr
- -- Apply its argument to a type argument `m` and a dictionary `Monad m`
- , monadWrapper :: CoreExpr -> CoreExpr
- -- Apply the container typed variable `m` to the argument type `T` to get `m T`.
- , metaTy :: Type -> Type
- -- Information about the wrappers which be printed to be inspected
- , _debugWrappers :: (HsWrapper, HsWrapper, Type)
- }
-
--- | Construct the functions which will apply the relevant part of the
--- QuoteWrapper to identifiers during desugaring.
-mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers
-mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do
- let quote_var = Var quote_var_raw
- -- Get the superclass selector to select the Monad dictionary, going
- -- to be used to construct the monadWrapper.
- quote_tc <- dsLookupTyCon quoteClassName
- monad_tc <- dsLookupTyCon monadClassName
- let Just cls = tyConClass_maybe quote_tc
- Just monad_cls = tyConClass_maybe monad_tc
- -- Quote m -> Monad m
- monad_sel = classSCSelId cls 0
-
- -- Only used for the defensive assertion that the selector has
- -- the expected type
- tyvars = dataConUserTyVarBinders (classDataCon cls)
- expected_ty = mkForAllTys tyvars $
- mkInvisFunTy (mkClassPred cls (mkTyVarTys (binderVars tyvars)))
- (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars)))
-
- MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty)
-
- let m_ty = Type m_var
- -- Construct the contents of MetaWrappers
- quoteWrapper = applyQuoteWrapper q
- monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.>
- mkWpTyApps [m_var]
- tyWrapper t = mkAppTy m_var t
- debug = (quoteWrapper, monadWrapper, m_var)
- q_f <- dsHsWrapper quoteWrapper
- m_f <- dsHsWrapper monadWrapper
- return (MetaWrappers q_f m_f tyWrapper debug)
-
--- Turn A into m A
-wrapName :: Name -> MetaM Type
-wrapName n = do
- t <- lookupType n
- wrap_fn <- asks metaTy
- return (wrap_fn t)
-
--- The local state is always the same, calculated from the passed in
--- wrapper
-type MetaM a = ReaderT MetaWrappers DsM a
-
------------------------------------------------------------------------------
-dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr
- -> HsBracket GhcRn
- -> [PendingTcSplice]
- -> DsM CoreExpr
--- See Note [Desugaring Brackets]
--- Returns a CoreExpr of type (M TH.Exp)
--- The quoted thing is parameterised over Name, even though it has
--- been type checked. We don't want all those type decorations!
-
-dsBracket wrap brack splices
- = do_brack brack
-
- where
- runOverloaded act = do
- -- In the overloaded case we have to get given a wrapper, it is just
- -- for variable quotations that there is no wrapper, because they
- -- have a simple type.
- mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)
- runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw
-
-
- new_bit = mkNameEnv [(n, DsSplice (unLoc e))
- | PendingTcSplice n e <- splices]
-
- do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM n ; return e1 }
- do_brack (ExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 }
- do_brack (PatBr _ p) = runOverloaded $ do { MkC p1 <- repTopP p ; return p1 }
- do_brack (TypBr _ t) = runOverloaded $ do { MkC t1 <- repLTy t ; return t1 }
- do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
- do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL"
- do_brack (TExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 }
- do_brack (XBracket nec) = noExtCon nec
-
-{-
-Note [Desugaring Brackets]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie
-an expression bracket was of type Q Exp. This made the desugaring process simple
-as there were no complicated type variables to keep consistent throughout the
-whole AST. Due to the overloaded quotations proposal a quotation bracket is now
-of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been
-generalised to work with any monad implementing a minimal interface.
-
-https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst
-
-Users can rejoice at the flexibility but now there is some additional complexity in
-how brackets are desugared as all these polymorphic combinators need their arguments
-instantiated.
-
-> IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD
-> USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR.
-
-What the arguments should be instantiated to is supplied by the `QuoteWrapper`
-datatype which is produced by `TcSplice`. It is a pair of an evidence variable
-for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring
-need to be applied to these two type variables.
-
-There are three important functions which do the application.
-
-1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument.
-2. `rep2M` takes a function name of type `Monad m => T` as an argument
-3. `rep2_nw` takes a function name without any constraints as an argument.
-
-These functions then use the information in QuoteWrapper to apply the correct
-arguments to the functions as the representation is constructed.
-
-The `MetaM` monad carries around an environment of three functions which are
-used in order to wrap the polymorphic combinators and instantiate the arguments
-to the correct things.
-
-1. quoteWrapper wraps functions of type `forall m . Quote m => T`
-2. monadWrapper wraps functions of type `forall m . Monad m => T`
-3. metaTy wraps a type in the polymorphic `m` variable of the whole representation.
-
-Historical note about the implementation: At the first attempt, I attempted to
-lie that the type of any quotation was `Quote m => m Exp` and then specialise it
-by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was
-simpler to implement but didn't work because of nested splices. For example,
-you might have a nested splice of a more specific type which fixes the type of
-the overall quote and so all the combinators used must also be instantiated to
-that specific type. Therefore you really have to use the contents of the quote
-wrapper to directly apply the right type to the combinators rather than
-first generate a polymorphic definition and then just apply the wrapper at the end.
-
--}
-
-{- -------------- Examples --------------------
-
- [| \x -> x |]
-====>
- gensym (unpackString "x"#) `bindQ` \ x1::String ->
- lam (pvar x1) (var x1)
-
-
- [| \x -> $(f [| x |]) |]
-====>
- gensym (unpackString "x"#) `bindQ` \ x1::String ->
- lam (pvar x1) (f (var x1))
--}
-
-
--------------------------------------------------------
--- Declarations
--------------------------------------------------------
-
--- Proxy for the phantom type of `Core`. All the generated fragments have
--- type something like `Quote m => m Exp` so to keep things simple we represent fragments
--- of that type as `M Exp`.
-data M a
-
-repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
-repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
- ; pat' <- addBinds ss (repLP pat)
- ; wrapGenSyms ss pat' }
-
-repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec]))
-repTopDs group@(HsGroup { hs_valds = valds
- , hs_splcds = splcds
- , hs_tyclds = tyclds
- , hs_derivds = derivds
- , hs_fixds = fixds
- , hs_defds = defds
- , hs_fords = fords
- , hs_warnds = warnds
- , hs_annds = annds
- , hs_ruleds = ruleds
- , hs_docs = docs })
- = do { let { bndrs = hsScopedTvBinders valds
- ++ hsGroupBinders group
- ++ hsPatSynSelectors valds
- ; instds = tyclds >>= group_instds } ;
- ss <- mkGenSyms bndrs ;
-
- -- Bind all the names mainly to avoid repeated use of explicit strings.
- -- Thus we get
- -- do { t :: String <- genSym "T" ;
- -- return (Data t [] ...more t's... }
- -- The other important reason is that the output must mention
- -- only "T", not "Foo:T" where Foo is the current module
-
- decls <- addBinds ss (
- do { val_ds <- rep_val_binds valds
- ; _ <- mapM no_splice splcds
- ; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds)
- ; role_ds <- mapM repRoleD (concatMap group_roles tyclds)
- ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)
- ; inst_ds <- mapM repInstD instds
- ; deriv_ds <- mapM repStandaloneDerivD derivds
- ; fix_ds <- mapM repLFixD fixds
- ; _ <- mapM no_default_decl defds
- ; for_ds <- mapM repForD fords
- ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc)
- warnds)
- ; ann_ds <- mapM repAnnD annds
- ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc)
- ruleds)
- ; _ <- mapM no_doc docs
-
- -- more needed
- ; return (de_loc $ sort_by_loc $
- val_ds ++ catMaybes tycl_ds ++ role_ds
- ++ kisig_ds
- ++ (concat fix_ds)
- ++ inst_ds ++ rule_ds ++ for_ds
- ++ ann_ds ++ deriv_ds) }) ;
-
- core_list <- repListM decTyConName return decls ;
-
- dec_ty <- lookupType decTyConName ;
- q_decs <- repSequenceM dec_ty core_list ;
-
- wrapGenSyms ss q_decs
- }
- where
- no_splice (L loc _)
- = notHandledL loc "Splices within declaration brackets" empty
- no_default_decl (L loc decl)
- = notHandledL loc "Default declarations" (ppr decl)
- no_warn (L loc (Warning _ thing _))
- = notHandledL loc "WARNING and DEPRECATION pragmas" $
- text "Pragma for declaration of" <+> ppr thing
- no_warn (L _ (XWarnDecl nec)) = noExtCon nec
- no_doc (L loc _)
- = notHandledL loc "Haddock documentation" empty
-repTopDs (XHsGroup nec) = noExtCon nec
-
-hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
--- See Note [Scoped type variables in bindings]
-hsScopedTvBinders binds
- = concatMap get_scoped_tvs sigs
- where
- sigs = case binds of
- ValBinds _ _ sigs -> sigs
- XValBindsLR (NValBinds _ sigs) -> sigs
-
-get_scoped_tvs :: LSig GhcRn -> [Name]
-get_scoped_tvs (L _ signature)
- | TypeSig _ _ sig <- signature
- = get_scoped_tvs_from_sig (hswc_body sig)
- | ClassOpSig _ _ _ sig <- signature
- = get_scoped_tvs_from_sig sig
- | PatSynSig _ _ sig <- signature
- = get_scoped_tvs_from_sig sig
- | otherwise
- = []
- where
- get_scoped_tvs_from_sig sig
- -- Both implicit and explicit quantified variables
- -- We need the implicit ones for f :: forall (a::k). blah
- -- here 'k' scopes too
- | HsIB { hsib_ext = implicit_vars
- , hsib_body = hs_ty } <- sig
- , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty
- = implicit_vars ++ hsLTyVarNames explicit_vars
- get_scoped_tvs_from_sig (XHsImplicitBndrs nec)
- = noExtCon nec
-
-{- Notes
-
-Note [Scoped type variables in bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- f :: forall a. a -> a
- f x = x::a
-Here the 'forall a' brings 'a' into scope over the binding group.
-To achieve this we
-
- a) Gensym a binding for 'a' at the same time as we do one for 'f'
- collecting the relevant binders with hsScopedTvBinders
-
- b) When processing the 'forall', don't gensym
-
-The relevant places are signposted with references to this Note
-
-Note [Scoped type variables in class and instance declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Scoped type variables may occur in default methods and default
-signatures. We need to bring the type variables in 'foralls'
-into the scope of the method bindings.
-
-Consider
- class Foo a where
- foo :: forall (b :: k). a -> Proxy b -> Proxy b
- foo _ x = (x :: Proxy b)
-
-We want to ensure that the 'b' in the type signature and the default
-implementation are the same, so we do the following:
-
- a) Before desugaring the signature and binding of 'foo', use
- get_scoped_tvs to collect type variables in 'forall' and
- create symbols for them.
- b) Use 'addBinds' to bring these symbols into the scope of the type
- signatures and bindings.
- c) Use these symbols to generate Core for the class/instance declaration.
-
-Note that when desugaring the signatures, we lookup the type variables
-from the scope rather than recreate symbols for them. See more details
-in "rep_ty_sig" and in Trac#14885.
-
-Note [Binders and occurrences]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we desugar [d| data T = MkT |]
-we want to get
- Data "T" [] [Con "MkT" []] []
-and *not*
- Data "Foo:T" [] [Con "Foo:MkT" []] []
-That is, the new data decl should fit into whatever new module it is
-asked to fit in. We do *not* clone, though; no need for this:
- Data "T79" ....
-
-But if we see this:
- data T = MkT
- foo = reifyDecl T
-
-then we must desugar to
- foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
-
-So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
-And we use lookupOcc, rather than lookupBinder
-in repTyClD and repC.
-
-Note [Don't quantify implicit type variables in quotes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If you're not careful, it's surprisingly easy to take this quoted declaration:
-
- [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b
- idProxy x = x
- |]
-
-and have Template Haskell turn it into this:
-
- idProxy :: forall k proxy (b :: k). proxy b -> proxy b
- idProxy x = x
-
-Notice that we explicitly quantified the variable `k`! The latter declaration
-isn't what the user wrote in the first place.
-
-Usually, the culprit behind these bugs is taking implicitly quantified type
-variables (often from the hsib_vars field of HsImplicitBinders) and putting
-them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
--}
-
--- represent associated family instances
---
-repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec)))
-
-repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
- repFamilyDecl (L loc fam)
-
-repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
- = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
- ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
- repSynDecl tc1 bndrs rhs
- ; return (Just (loc, dec)) }
-
-repTyClD (L loc (DataDecl { tcdLName = tc
- , tcdTyVars = tvs
- , tcdDataDefn = defn }))
- = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
- ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
- repDataDefn tc1 (Left bndrs) defn
- ; return (Just (loc, dec)) }
-
-repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
- tcdTyVars = tvs, tcdFDs = fds,
- tcdSigs = sigs, tcdMeths = meth_binds,
- tcdATs = ats, tcdATDefs = atds }))
- = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
- ; dec <- addTyVarBinds tvs $ \bndrs ->
- do { cxt1 <- repLContext cxt
- -- See Note [Scoped type variables in class and instance declarations]
- ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds
- ; fds1 <- repLFunDeps fds
- ; ats1 <- repFamilyDecls ats
- ; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds
- ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)
- ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
- ; wrapGenSyms ss decls2 }
- ; return $ Just (loc, dec)
- }
-
-repTyClD (L _ (XTyClDecl nec)) = noExtCon nec
-
--------------------------
-repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repRoleD (L loc (RoleAnnotDecl _ tycon roles))
- = do { tycon1 <- lookupLOcc tycon
- ; roles1 <- mapM repRole roles
- ; roles2 <- coreList roleTyConName roles1
- ; dec <- repRoleAnnotD tycon1 roles2
- ; return (loc, dec) }
-repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec
-
--------------------------
-repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repKiSigD (L loc kisig) =
- case kisig of
- StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v
- XStandaloneKindSig nec -> noExtCon nec
-
--------------------------
-repDataDefn :: Core TH.Name
- -> Either (Core [(M TH.TyVarBndr)])
- -- the repTyClD case
- (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))
- -- the repDataFamInstD case
- -> HsDataDefn GhcRn
- -> MetaM (Core (M TH.Dec))
-repDataDefn tc opts
- (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
- , dd_cons = cons, dd_derivs = mb_derivs })
- = do { cxt1 <- repLContext cxt
- ; derivs1 <- repDerivs mb_derivs
- ; case (new_or_data, cons) of
- (NewType, [con]) -> do { con' <- repC con
- ; ksig' <- repMaybeLTy ksig
- ; repNewtype cxt1 tc opts ksig' con'
- derivs1 }
- (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:"
- <+> pprQuotedList
- (getConNames $ unLoc $ head cons))
- (DataType, _) -> do { ksig' <- repMaybeLTy ksig
- ; consL <- mapM repC cons
- ; cons1 <- coreListM conTyConName consL
- ; repData cxt1 tc opts ksig' cons1
- derivs1 }
- }
-repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec
-
-repSynDecl :: Core TH.Name -> Core [(M TH.TyVarBndr)]
- -> LHsType GhcRn
- -> MetaM (Core (M TH.Dec))
-repSynDecl tc bndrs ty
- = do { ty1 <- repLTy ty
- ; repTySyn tc bndrs ty1 }
-
-repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info
- , fdLName = tc
- , fdTyVars = tvs
- , fdResultSig = L _ resultSig
- , fdInjectivityAnn = injectivity }))
- = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
- ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
- mkHsQTvs tvs = HsQTvs { hsq_ext = []
- , hsq_explicit = tvs }
- resTyVar = case resultSig of
- TyVarSig _ bndr -> mkHsQTvs [bndr]
- _ -> mkHsQTvs []
- ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
- addTyClTyVarBinds resTyVar $ \_ ->
- case info of
- ClosedTypeFamily Nothing ->
- notHandled "abstract closed type family" (ppr decl)
- ClosedTypeFamily (Just eqns) ->
- do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns
- ; eqns2 <- coreListM tySynEqnTyConName eqns1
- ; result <- repFamilyResultSig resultSig
- ; inj <- repInjectivityAnn injectivity
- ; repClosedFamilyD tc1 bndrs result inj eqns2 }
- OpenTypeFamily ->
- do { result <- repFamilyResultSig resultSig
- ; inj <- repInjectivityAnn injectivity
- ; repOpenFamilyD tc1 bndrs result inj }
- DataFamily ->
- do { kind <- repFamilyResultSigToMaybeKind resultSig
- ; repDataFamilyD tc1 bndrs kind }
- ; return (loc, dec)
- }
-repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec
-
--- | Represent result signature of a type family
-repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig))
-repFamilyResultSig (NoSig _) = repNoSig
-repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki
- ; repKindSig ki' }
-repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
- ; repTyVarSig bndr' }
-repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec
-
--- | Represent result signature using a Maybe Kind. Used with data families,
--- where the result signature can be either missing or a kind but never a named
--- result variable.
-repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
- -> MetaM (Core (Maybe (M TH.Kind)))
-repFamilyResultSigToMaybeKind (NoSig _) =
- do { coreNothingM kindTyConName }
-repFamilyResultSigToMaybeKind (KindSig _ ki) =
- do { coreJustM kindTyConName =<< repLTy ki }
-repFamilyResultSigToMaybeKind TyVarSig{} =
- panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig"
-repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec
-
--- | Represent injectivity annotation of a type family
-repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
- -> MetaM (Core (Maybe TH.InjectivityAnn))
-repInjectivityAnn Nothing =
- do { coreNothing injAnnTyConName }
-repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
- do { lhs' <- lookupBinder (unLoc lhs)
- ; rhs1 <- mapM (lookupBinder . unLoc) rhs
- ; rhs2 <- coreList nameTyConName rhs1
- ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2]
- ; coreJust injAnnTyConName injAnn }
-
-repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)]
-repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
-
-repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec))
-repAssocTyFamDefaultD = repTyFamInstD
-
--------------------------
--- represent fundeps
---
-repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep])
-repLFunDeps fds = repList funDepTyConName repLFunDep fds
-
-repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep)
-repLFunDep (L _ (xs, ys))
- = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
- ys' <- repList nameTyConName (lookupBinder . unLoc) ys
- repFunDep xs' ys'
-
--- Represent instance declarations
---
-repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
- = do { dec <- repTyFamInstD fi_decl
- ; return (loc, dec) }
-repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
- = do { dec <- repDataFamInstD fi_decl
- ; return (loc, dec) }
-repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
- = do { dec <- repClsInstD cls_decl
- ; return (loc, dec) }
-repInstD (L _ (XInstDecl nec)) = noExtCon nec
-
-repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec))
-repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
- , cid_sigs = sigs, cid_tyfam_insts = ats
- , cid_datafam_insts = adts
- , cid_overlap_mode = overlap
- })
- = addSimpleTyVarBinds tvs $
- -- We must bring the type variables into scope, so their
- -- occurrences don't fail, even though the binders don't
- -- appear in the resulting data structure
- --
- -- But we do NOT bring the binders of 'binds' into scope
- -- because they are properly regarded as occurrences
- -- For example, the method names should be bound to
- -- the selector Ids, not to fresh names (#5410)
- --
- do { cxt1 <- repLContext cxt
- ; inst_ty1 <- repLTy inst_ty
- -- See Note [Scoped type variables in class and instance declarations]
- ; (ss, sigs_binds) <- rep_sigs_binds sigs binds
- ; ats1 <- mapM (repTyFamInstD . unLoc) ats
- ; adts1 <- mapM (repDataFamInstD . unLoc) adts
- ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)
- ; rOver <- repOverlap (fmap unLoc overlap)
- ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
- ; wrapGenSyms ss decls2 }
- where
- (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
-repClsInstD (XClsInstDecl nec) = noExtCon nec
-
-repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
- , deriv_type = ty }))
- = do { dec <- addSimpleTyVarBinds tvs $
- do { cxt' <- repLContext cxt
- ; strat' <- repDerivStrategy strat
- ; inst_ty' <- repLTy inst_ty
- ; repDeriv strat' cxt' inst_ty' }
- ; return (loc, dec) }
- where
- (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
-repStandaloneDerivD (L _ (XDerivDecl nec)) = noExtCon nec
-
-repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
-repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
- = do { eqn1 <- repTyFamEqn eqn
- ; repTySynInst eqn1 }
-
-repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))
-repTyFamEqn (HsIB { hsib_ext = var_names
- , hsib_body = FamEqn { feqn_tycon = tc_name
- , feqn_bndrs = mb_bndrs
- , feqn_pats = tys
- , feqn_fixity = fixity
- , feqn_rhs = rhs }})
- = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
- ; let hs_tvs = HsQTvs { hsq_ext = var_names
- , hsq_explicit = fromMaybe [] mb_bndrs }
- ; addTyClTyVarBinds hs_tvs $ \ _ ->
- do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName
- repTyVarBndr
- mb_bndrs
- ; tys1 <- case fixity of
- Prefix -> repTyArgs (repNamedTyCon tc) tys
- Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
- ; t1' <- repLTy t1
- ; t2' <- repLTy t2
- ; repTyArgs (repTInfix t1' tc t2') args }
- ; rhs1 <- repLTy rhs
- ; repTySynEqn mb_bndrs1 tys1 rhs1 } }
- where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
- checkTys tys@(HsValArg _:HsValArg _:_) = return tys
- checkTys _ = panic "repTyFamEqn:checkTys"
-repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec
-repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec
-
-repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type))
-repTyArgs f [] = f
-repTyArgs f (HsValArg ty : as) = do { f' <- f
- ; ty' <- repLTy ty
- ; repTyArgs (repTapp f' ty') as }
-repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
- ; ki' <- repLTy ki
- ; repTyArgs (repTappKind f' ki') as }
-repTyArgs f (HsArgPar _ : as) = repTyArgs f as
-
-repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
-repDataFamInstD (DataFamInstDecl { dfid_eqn =
- (HsIB { hsib_ext = var_names
- , hsib_body = FamEqn { feqn_tycon = tc_name
- , feqn_bndrs = mb_bndrs
- , feqn_pats = tys
- , feqn_fixity = fixity
- , feqn_rhs = defn }})})
- = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
- ; let hs_tvs = HsQTvs { hsq_ext = var_names
- , hsq_explicit = fromMaybe [] mb_bndrs }
- ; addTyClTyVarBinds hs_tvs $ \ _ ->
- do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName
- repTyVarBndr
- mb_bndrs
- ; tys1 <- case fixity of
- Prefix -> repTyArgs (repNamedTyCon tc) tys
- Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
- ; t1' <- repLTy t1
- ; t2' <- repLTy t2
- ; repTyArgs (repTInfix t1' tc t2') args }
- ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
-
- where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
- checkTys tys@(HsValArg _: HsValArg _: _) = return tys
- checkTys _ = panic "repDataFamInstD:checkTys"
-
-repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec))
- = noExtCon nec
-repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))
- = noExtCon nec
-
-repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec))
-repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
- , fd_fi = CImport (L _ cc)
- (L _ s) mch cis _ }))
- = do MkC name' <- lookupLOcc name
- MkC typ' <- repHsSigType typ
- MkC cc' <- repCCallConv cc
- MkC s' <- repSafety s
- cis' <- conv_cimportspec cis
- MkC str <- coreStringLit (static ++ chStr ++ cis')
- dec <- rep2 forImpDName [cc', s', str, name', typ']
- return (loc, dec)
- where
- conv_cimportspec (CLabel cls)
- = notHandled "Foreign label" (doubleQuotes (ppr cls))
- conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
- conv_cimportspec (CFunction (StaticTarget _ fs _ True))
- = return (unpackFS fs)
- conv_cimportspec (CFunction (StaticTarget _ _ _ False))
- = panic "conv_cimportspec: values not supported yet"
- conv_cimportspec CWrapper = return "wrapper"
- -- these calling conventions do not support headers and the static keyword
- raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
- static = case cis of
- CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
- _ -> ""
- chStr = case mch of
- Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
- _ -> ""
-repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl)
-repForD (L _ (XForeignDecl nec)) = noExtCon nec
-
-repCCallConv :: CCallConv -> MetaM (Core TH.Callconv)
-repCCallConv CCallConv = rep2_nw cCallName []
-repCCallConv StdCallConv = rep2_nw stdCallName []
-repCCallConv CApiConv = rep2_nw cApiCallName []
-repCCallConv PrimCallConv = rep2_nw primCallName []
-repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName []
-
-repSafety :: Safety -> MetaM (Core TH.Safety)
-repSafety PlayRisky = rep2_nw unsafeName []
-repSafety PlayInterruptible = rep2_nw interruptibleName []
-repSafety PlaySafe = rep2_nw safeName []
-
-repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-repLFixD (L loc fix_sig) = rep_fix_d loc fix_sig
-
-rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))
- = do { MkC prec' <- coreIntLit prec
- ; let rep_fn = case dir of
- InfixL -> infixLDName
- InfixR -> infixRDName
- InfixN -> infixNDName
- ; let do_one name
- = do { MkC name' <- lookupLOcc name
- ; dec <- rep2 rep_fn [prec', name']
- ; return (loc,dec) }
- ; mapM do_one names }
-rep_fix_d _ (XFixitySig nec) = noExtCon nec
-
-repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repRuleD (L loc (HsRule { rd_name = n
- , rd_act = act
- , rd_tyvs = ty_bndrs
- , rd_tmvs = tm_bndrs
- , rd_lhs = lhs
- , rd_rhs = rhs }))
- = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
- do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
- ; ss <- mkGenSyms tm_bndr_names
- ; rule <- addBinds ss $
- do { elt_ty <- wrapName tyVarBndrTyConName
- ; ty_bndrs' <- return $ case ty_bndrs of
- Nothing -> coreNothing' (mkListTy elt_ty)
- Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs
- ; tm_bndrs' <- repListM ruleBndrTyConName
- repRuleBndr
- tm_bndrs
- ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n
- ; act' <- repPhases act
- ; lhs' <- repLE lhs
- ; rhs' <- repLE rhs
- ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
- ; wrapGenSyms ss rule }
- ; return (loc, rule) }
-repRuleD (L _ (XRuleDecl nec)) = noExtCon nec
-
-ruleBndrNames :: LRuleBndr GhcRn -> [Name]
-ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]
-ruleBndrNames (L _ (RuleBndrSig _ n sig))
- | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
- = unLoc n : vars
-ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs nec))))
- = noExtCon nec
-ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec)))
- = noExtCon nec
-ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec
-
-repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr))
-repRuleBndr (L _ (RuleBndr _ n))
- = do { MkC n' <- lookupLBinder n
- ; rep2 ruleVarName [n'] }
-repRuleBndr (L _ (RuleBndrSig _ n sig))
- = do { MkC n' <- lookupLBinder n
- ; MkC ty' <- repLTy (hsSigWcType sig)
- ; rep2 typedRuleVarName [n', ty'] }
-repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec
-
-repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
- = do { target <- repAnnProv ann_prov
- ; exp' <- repE exp
- ; dec <- repPragAnn target exp'
- ; return (loc, dec) }
-repAnnD (L _ (XAnnDecl nec)) = noExtCon nec
-
-repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget)
-repAnnProv (ValueAnnProvenance (L _ n))
- = do { MkC n' <- lift $ globalVar n -- ANNs are allowed only at top-level
- ; rep2_nw valueAnnotationName [ n' ] }
-repAnnProv (TypeAnnProvenance (L _ n))
- = do { MkC n' <- lift $ globalVar n
- ; rep2_nw typeAnnotationName [ n' ] }
-repAnnProv ModuleAnnProvenance
- = rep2_nw moduleAnnotationName []
-
--------------------------------------------------------
--- Constructors
--------------------------------------------------------
-
-repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con))
-repC (L _ (ConDeclH98 { con_name = con
- , con_forall = (L _ False)
- , con_mb_cxt = Nothing
- , con_args = args }))
- = repDataCon con args
-
-repC (L _ (ConDeclH98 { con_name = con
- , con_forall = L _ is_existential
- , con_ex_tvs = con_tvs
- , con_mb_cxt = mcxt
- , con_args = args }))
- = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
- do { c' <- repDataCon con args
- ; ctxt' <- repMbContext mcxt
- ; if not is_existential && isNothing mcxt
- then return c'
- else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
- }
- }
-
-repC (L _ (ConDeclGADT { con_names = cons
- , con_qvars = qtvs
- , con_mb_cxt = mcxt
- , con_args = args
- , con_res_ty = res_ty }))
- | isEmptyLHsQTvs qtvs -- No implicit or explicit variables
- , Nothing <- mcxt -- No context
- -- ==> no need for a forall
- = repGadtDataCons cons args res_ty
-
- | otherwise
- = addTyVarBinds qtvs $ \ ex_bndrs ->
- -- See Note [Don't quantify implicit type variables in quotes]
- do { c' <- repGadtDataCons cons args res_ty
- ; ctxt' <- repMbContext mcxt
- ; if null (hsQTvExplicit qtvs) && isNothing mcxt
- then return c'
- else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
-
-repC (L _ (XConDecl nec)) = noExtCon nec
-
-
-repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
-repMbContext Nothing = repContext []
-repMbContext (Just (L _ cxt)) = repContext cxt
-
-repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness))
-repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName []
-repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName []
-repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []
-
-repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness))
-repSrcStrictness SrcLazy = rep2 sourceLazyName []
-repSrcStrictness SrcStrict = rep2 sourceStrictName []
-repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
-
-repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType))
-repBangTy ty = do
- MkC u <- repSrcUnpackedness su'
- MkC s <- repSrcStrictness ss'
- MkC b <- rep2 bangName [u, s]
- MkC t <- repLTy ty'
- rep2 bangTypeName [b, t]
- where
- (su', ss', ty') = case unLoc ty of
- HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)
- _ -> (NoSrcUnpack, NoSrcStrict, ty)
-
--------------------------------------------------------
--- Deriving clauses
--------------------------------------------------------
-
-repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause])
-repDerivs (L _ clauses)
- = repListM derivClauseTyConName repDerivClause clauses
-
-repDerivClause :: LHsDerivingClause GhcRn
- -> MetaM (Core (M TH.DerivClause))
-repDerivClause (L _ (HsDerivingClause
- { deriv_clause_strategy = dcs
- , deriv_clause_tys = L _ dct }))
- = do MkC dcs' <- repDerivStrategy dcs
- MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct
- rep2 derivClauseName [dcs',dct']
- where
- rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type))
- rep_deriv_ty ty = repLTy ty
-repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec
-
-rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
- -> MetaM ([GenSymBind], [Core (M TH.Dec)])
--- Represent signatures and methods in class/instance declarations.
--- See Note [Scoped type variables in class and instance declarations]
---
--- Why not use 'repBinds': we have already created symbols for methods in
--- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
--- these fun_id via 'collectHsValBinders decs', which would lead to the
--- instance declarations failing in TH.
-rep_sigs_binds sigs binds
- = do { let tvs = concatMap get_scoped_tvs sigs
- ; ss <- mkGenSyms tvs
- ; sigs1 <- addBinds ss $ rep_sigs sigs
- ; binds1 <- addBinds ss $ rep_binds binds
- ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }
-
--------------------------------------------------------
--- Signatures in a class decl, or a group of bindings
--------------------------------------------------------
-
-rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M TH.Dec))]
- -- We silently ignore ones we don't recognise
-rep_sigs = concatMapM rep_sig
-
-rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_sig (L loc (TypeSig _ nms ty))
- = mapM (rep_wc_ty_sig sigDName loc ty) nms
-rep_sig (L loc (PatSynSig _ nms ty))
- = mapM (rep_patsyn_ty_sig loc ty) nms
-rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
- | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
- | otherwise = mapM (rep_ty_sig sigDName loc ty) nms
-rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
-rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d loc fix_sig
-rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
-rep_sig (L loc (SpecSig _ nm tys ispec))
- = concatMapM (\t -> rep_specialise nm t ispec loc) tys
-rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
-rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
-rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
-rep_sig (L loc (CompleteMatchSig _ _st cls mty))
- = rep_complete_sig cls mty loc
-rep_sig (L _ (XSig nec)) = noExtCon nec
-
-rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
- -> MetaM (SrcSpan, Core (M TH.Dec))
--- Don't create the implicit and explicit variables when desugaring signatures,
--- see Note [Scoped type variables in class and instance declarations].
--- and Note [Don't quantify implicit type variables in quotes]
-rep_ty_sig mk_sig loc sig_ty nm
- | HsIB { hsib_body = hs_ty } <- sig_ty
- , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty
- = do { nm1 <- lookupLOcc nm
- ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
- ; repTyVarBndrWithKind tv name }
- ; th_explicit_tvs <- repListM tyVarBndrTyConName rep_in_scope_tv
- explicit_tvs
-
- -- NB: Don't pass any implicit type variables to repList above
- -- See Note [Don't quantify implicit type variables in quotes]
-
- ; th_ctxt <- repLContext ctxt
- ; th_ty <- repLTy ty
- ; ty1 <- if null explicit_tvs && null (unLoc ctxt)
- then return th_ty
- else repTForall th_explicit_tvs th_ctxt th_ty
- ; sig <- repProto mk_sig nm1 ty1
- ; return (loc, sig) }
-rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec
-
-rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
- -> MetaM (SrcSpan, Core (M TH.Dec))
--- represents a pattern synonym type signature;
--- see Note [Pattern synonym type signatures and Template Haskell] in Convert
---
--- Don't create the implicit and explicit variables when desugaring signatures,
--- see Note [Scoped type variables in class and instance declarations]
--- and Note [Don't quantify implicit type variables in quotes]
-rep_patsyn_ty_sig loc sig_ty nm
- | HsIB { hsib_body = hs_ty } <- sig_ty
- , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty
- = do { nm1 <- lookupLOcc nm
- ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
- ; repTyVarBndrWithKind tv name }
- ; th_univs <- repListM tyVarBndrTyConName rep_in_scope_tv univs
- ; th_exis <- repListM tyVarBndrTyConName rep_in_scope_tv exis
-
- -- NB: Don't pass any implicit type variables to repList above
- -- See Note [Don't quantify implicit type variables in quotes]
-
- ; th_reqs <- repLContext reqs
- ; th_provs <- repLContext provs
- ; th_ty <- repLTy ty
- ; ty1 <- repTForall th_univs th_reqs =<<
- repTForall th_exis th_provs th_ty
- ; sig <- repProto patSynSigDName nm1 ty1
- ; return (loc, sig) }
-rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec
-
-rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
- -> MetaM (SrcSpan, Core (M TH.Dec))
-rep_wc_ty_sig mk_sig loc sig_ty nm
- = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm
-
-rep_inline :: Located Name
- -> InlinePragma -- Never defaultInlinePragma
- -> SrcSpan
- -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_inline nm ispec loc
- = do { nm1 <- lookupLOcc nm
- ; inline <- repInline $ inl_inline ispec
- ; rm <- repRuleMatch $ inl_rule ispec
- ; phases <- repPhases $ inl_act ispec
- ; pragma <- repPragInl nm1 inline rm phases
- ; return [(loc, pragma)]
- }
-
-rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma
- -> SrcSpan
- -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_specialise nm ty ispec loc
- = do { nm1 <- lookupLOcc nm
- ; ty1 <- repHsSigType ty
- ; phases <- repPhases $ inl_act ispec
- ; let inline = inl_inline ispec
- ; pragma <- if noUserInlineSpec inline
- then -- SPECIALISE
- repPragSpec nm1 ty1 phases
- else -- SPECIALISE INLINE
- do { inline1 <- repInline inline
- ; repPragSpecInl nm1 ty1 inline1 phases }
- ; return [(loc, pragma)]
- }
-
-rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
- -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_specialiseInst ty loc
- = do { ty1 <- repHsSigType ty
- ; pragma <- repPragSpecInst ty1
- ; return [(loc, pragma)] }
-
-repInline :: InlineSpec -> MetaM (Core TH.Inline)
-repInline NoInline = dataCon noInlineDataConName
-repInline Inline = dataCon inlineDataConName
-repInline Inlinable = dataCon inlinableDataConName
-repInline NoUserInline = notHandled "NOUSERINLINE" empty
-
-repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch)
-repRuleMatch ConLike = dataCon conLikeDataConName
-repRuleMatch FunLike = dataCon funLikeDataConName
-
-repPhases :: Activation -> MetaM (Core TH.Phases)
-repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
- ; dataCon' beforePhaseDataConName [arg] }
-repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i
- ; dataCon' fromPhaseDataConName [arg] }
-repPhases _ = dataCon allPhasesDataConName
-
-rep_complete_sig :: Located [Located Name]
- -> Maybe (Located Name)
- -> SrcSpan
- -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_complete_sig (L _ cls) mty loc
- = do { mty' <- repMaybe nameTyConName lookupLOcc mty
- ; cls' <- repList nameTyConName lookupLOcc cls
- ; sig <- repPragComplete cls' mty'
- ; return [(loc, sig)] }
-
--------------------------------------------------------
--- Types
--------------------------------------------------------
-
-addSimpleTyVarBinds :: [Name] -- the binders to be added
- -> MetaM (Core (M a)) -- action in the ext env
- -> MetaM (Core (M a))
-addSimpleTyVarBinds names thing_inside
- = do { fresh_names <- mkGenSyms names
- ; term <- addBinds fresh_names thing_inside
- ; wrapGenSyms fresh_names term }
-
-addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added
- -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env
- -> MetaM (Core (M a))
-addHsTyVarBinds exp_tvs thing_inside
- = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)
- ; term <- addBinds fresh_exp_names $
- do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr
- (exp_tvs `zip` fresh_exp_names)
- ; thing_inside kbs }
- ; wrapGenSyms fresh_exp_names term }
- where
- mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
-
-addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
- -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env
- -> MetaM (Core (M a))
--- gensym a list of type variables and enter them into the meta environment;
--- the computations passed as the second argument is executed in that extended
--- meta environment and gets the *new* names on Core-level as an argument
-addTyVarBinds (HsQTvs { hsq_ext = imp_tvs
- , hsq_explicit = exp_tvs })
- thing_inside
- = addSimpleTyVarBinds imp_tvs $
- addHsTyVarBinds exp_tvs $
- thing_inside
-addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec
-
-addTyClTyVarBinds :: LHsQTyVars GhcRn
- -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a)))
- -> MetaM (Core (M a))
-
--- Used for data/newtype declarations, and family instances,
--- so that the nested type variables work right
--- instance C (T a) where
--- type W (T a) = blah
--- The 'a' in the type instance is the one bound by the instance decl
-addTyClTyVarBinds tvs m
- = do { let tv_names = hsAllLTyVarNames tvs
- ; env <- lift $ dsGetMetaEnv
- ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
- -- Make fresh names for the ones that are not already in scope
- -- This makes things work for family declarations
-
- ; term <- addBinds freshNames $
- do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr
- (hsQTvExplicit tvs)
- ; m kbs }
-
- ; wrapGenSyms freshNames term }
- where
- mk_tv_bndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr))
- mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
- ; repTyVarBndrWithKind tv v }
-
--- Produce kinded binder constructors from the Haskell tyvar binders
---
-repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
- -> Core TH.Name -> MetaM (Core (M TH.TyVarBndr))
-repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
- = repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
- = repLTy ki >>= repKindedTV nm
-repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec
-
--- | Represent a type variable binder
-repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr))
-repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )
- = do { nm' <- lookupBinder nm
- ; repPlainTV nm' }
-repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki))
- = do { nm' <- lookupBinder nm
- ; ki' <- repLTy ki
- ; repKindedTV nm' ki' }
-repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec
-
--- represent a type context
---
-repLContext :: LHsContext GhcRn -> MetaM (Core (M TH.Cxt))
-repLContext ctxt = repContext (unLoc ctxt)
-
-repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt))
-repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt
- repCtxt preds
-
-repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))
-repHsSigType (HsIB { hsib_ext = implicit_tvs
- , hsib_body = body })
- | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body
- = addSimpleTyVarBinds implicit_tvs $
- -- See Note [Don't quantify implicit type variables in quotes]
- addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
- do { th_ctxt <- repLContext ctxt
- ; th_ty <- repLTy ty
- ; if null explicit_tvs && null (unLoc ctxt)
- then return th_ty
- else repTForall th_explicit_tvs th_ctxt th_ty }
-repHsSigType (XHsImplicitBndrs nec) = noExtCon nec
-
-repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type))
-repHsSigWcType (HsWC { hswc_body = sig1 })
- = repHsSigType sig1
-repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec
-
--- yield the representation of a list of types
-repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]
-repLTys tys = mapM repLTy tys
-
--- represent a type
-repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type))
-repLTy ty = repTy (unLoc ty)
-
--- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or
--- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax.
--- In other words, the argument to this function is always an
--- @HsForAllTy ForallInvis@ or @HsQualTy@.
--- Types headed by visible foralls (which are desugared to ForallVisT) are
--- handled separately in repTy.
-repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))
-repForallT ty
- | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty)
- = addHsTyVarBinds tvs $ \bndrs ->
- do { ctxt1 <- repLContext ctxt
- ; tau1 <- repLTy tau
- ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...}
- }
-
-repTy :: HsType GhcRn -> MetaM (Core (M TH.Type))
-repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) =
- case fvf of
- ForallInvis -> repForallT ty
- ForallVis -> addHsTyVarBinds tvs $ \bndrs ->
- do body1 <- repLTy body
- repTForallVis bndrs body1
-repTy ty@(HsQualTy {}) = repForallT ty
-
-repTy (HsTyVar _ _ (L _ n))
- | isLiftedTypeKindTyConName n = repTStar
- | n `hasKey` constraintKindTyConKey = repTConstraint
- | n `hasKey` funTyConKey = repArrowTyCon
- | isTvOcc occ = do tv1 <- lookupOcc n
- repTvar tv1
- | isDataOcc occ = do tc1 <- lookupOcc n
- repPromotedDataCon tc1
- | n == eqTyConName = repTequality
- | otherwise = do tc1 <- lookupOcc n
- repNamedTyCon tc1
- where
- occ = nameOccName n
-
-repTy (HsAppTy _ f a) = do
- f1 <- repLTy f
- a1 <- repLTy a
- repTapp f1 a1
-repTy (HsAppKindTy _ ty ki) = do
- ty1 <- repLTy ty
- ki1 <- repLTy ki
- repTappKind ty1 ki1
-repTy (HsFunTy _ f a) = do
- f1 <- repLTy f
- a1 <- repLTy a
- tcon <- repArrowTyCon
- repTapps tcon [f1, a1]
-repTy (HsListTy _ t) = do
- t1 <- repLTy t
- tcon <- repListTyCon
- repTapp tcon t1
-repTy (HsTupleTy _ HsUnboxedTuple tys) = do
- tys1 <- repLTys tys
- tcon <- repUnboxedTupleTyCon (length tys)
- repTapps tcon tys1
-repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys
- tcon <- repTupleTyCon (length tys)
- repTapps tcon tys1
-repTy (HsSumTy _ tys) = do tys1 <- repLTys tys
- tcon <- repUnboxedSumTyCon (length tys)
- repTapps tcon tys1
-repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
- `nlHsAppTy` ty2)
-repTy (HsParTy _ t) = repLTy t
-repTy (HsStarTy _ _) = repTStar
-repTy (HsKindSig _ t k) = do
- t1 <- repLTy t
- k1 <- repLTy k
- repTSig t1 k1
-repTy (HsSpliceTy _ splice) = repSplice splice
-repTy (HsExplicitListTy _ _ tys) = do
- tys1 <- repLTys tys
- repTPromotedList tys1
-repTy (HsExplicitTupleTy _ tys) = do
- tys1 <- repLTys tys
- tcon <- repPromotedTupleTyCon (length tys)
- repTapps tcon tys1
-repTy (HsTyLit _ lit) = do
- lit' <- repTyLit lit
- repTLit lit'
-repTy (HsWildCardTy _) = repTWildCard
-repTy (HsIParamTy _ n t) = do
- n' <- rep_implicit_param_name (unLoc n)
- t' <- repLTy t
- repTImplicitParam n' t'
-
-repTy ty = notHandled "Exotic form of type" (ppr ty)
-
-repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))
-repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
- rep2 numTyLitName [iExpr]
-repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
- ; rep2 strTyLitName [s']
- }
-
--- | Represent a type wrapped in a Maybe
-repMaybeLTy :: Maybe (LHsKind GhcRn)
- -> MetaM (Core (Maybe (M TH.Type)))
-repMaybeLTy m = do
- k_ty <- wrapName kindTyConName
- repMaybeT k_ty repLTy m
-
-repRole :: Located (Maybe Role) -> MetaM (Core TH.Role)
-repRole (L _ (Just Nominal)) = rep2_nw nominalRName []
-repRole (L _ (Just Representational)) = rep2_nw representationalRName []
-repRole (L _ (Just Phantom)) = rep2_nw phantomRName []
-repRole (L _ Nothing) = rep2_nw inferRName []
-
------------------------------------------------------------------------------
--- Splices
------------------------------------------------------------------------------
-
-repSplice :: HsSplice GhcRn -> MetaM (Core a)
--- See Note [How brackets and nested splices are handled] in TcSplice
--- We return a CoreExpr of any old type; the context should know
-repSplice (HsTypedSplice _ _ n _) = rep_splice n
-repSplice (HsUntypedSplice _ _ n _) = rep_splice n
-repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n
-repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e)
-repSplice e@(HsSplicedT {}) = pprPanic "repSpliceT" (ppr e)
-repSplice (XSplice nec) = noExtCon nec
-
-rep_splice :: Name -> MetaM (Core a)
-rep_splice splice_name
- = do { mb_val <- lift $ dsLookupMetaEnv splice_name
- ; case mb_val of
- Just (DsSplice e) -> do { e' <- lift $ dsExpr e
- ; return (MkC e') }
- _ -> pprPanic "HsSplice" (ppr splice_name) }
- -- Should not happen; statically checked
-
------------------------------------------------------------------------------
--- Expressions
------------------------------------------------------------------------------
-
-repLEs :: [LHsExpr GhcRn] -> MetaM (Core [(M TH.Exp)])
-repLEs es = repListM expTyConName repLE es
-
--- FIXME: some of these panics should be converted into proper error messages
--- unless we can make sure that constructs, which are plainly not
--- supported in TH already lead to error messages at an earlier stage
-repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp))
-repLE (L loc e) = mapReaderT (putSrcSpanDs loc) (repE e)
-
-repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp))
-repE (HsVar _ (L _ x)) =
- do { mb_val <- lift $ dsLookupMetaEnv x
- ; case mb_val of
- Nothing -> do { str <- lift $ globalVar x
- ; repVarOrCon x str }
- Just (DsBound y) -> repVarOrCon x (coreVar y)
- Just (DsSplice e) -> do { e' <- lift $ dsExpr e
- ; return (MkC e') } }
-repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
-repE (HsOverLabel _ _ s) = repOverLabel s
-
-repE e@(HsRecFld _ f) = case f of
- Unambiguous x _ -> repE (HsVar noExtField (noLoc x))
- Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
- XAmbiguousFieldOcc nec -> noExtCon nec
-
- -- Remember, we're desugaring renamer output here, so
- -- HsOverlit can definitely occur
-repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
-repE (HsLit _ l) = do { a <- repLiteral l; repLit a }
-repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m
-repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))
- = do { ms' <- mapM repMatchTup ms
- ; core_ms <- coreListM matchTyConName ms'
- ; repLamCase core_ms }
-repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
-repE (HsAppType _ e t) = do { a <- repLE e
- ; s <- repLTy (hswc_body t)
- ; repAppType a s }
-
-repE (OpApp _ e1 op e2) =
- do { arg1 <- repLE e1;
- arg2 <- repLE e2;
- the_op <- repLE op ;
- repInfixApp arg1 the_op arg2 }
-repE (NegApp _ x _) = do
- a <- repLE x
- negateVar <- lookupOcc negateName >>= repVar
- negateVar `repApp` a
-repE (HsPar _ x) = repLE x
-repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
-repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase _ e (MG { mg_alts = (L _ ms) }))
- = do { arg <- repLE e
- ; ms2 <- mapM repMatchTup ms
- ; core_ms2 <- coreListM matchTyConName ms2
- ; repCaseE arg core_ms2 }
-repE (HsIf _ _ x y z) = do
- a <- repLE x
- b <- repLE y
- c <- repLE z
- repCond a b c
-repE (HsMultiIf _ alts)
- = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
- ; expr' <- repMultiIf (nonEmptyCoreList alts')
- ; wrapGenSyms (concat binds) expr' }
-repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs
- ; e2 <- addBinds ss (repLE e)
- ; z <- repLetE ds e2
- ; wrapGenSyms ss z }
-
--- FIXME: I haven't got the types here right yet
-repE e@(HsDo _ ctxt (L _ sts))
- | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
- = do { (ss,zs) <- repLSts sts;
- e' <- repDoE (nonEmptyCoreList zs);
- wrapGenSyms ss e' }
-
- | ListComp <- ctxt
- = do { (ss,zs) <- repLSts sts;
- e' <- repComp (nonEmptyCoreList zs);
- wrapGenSyms ss e' }
-
- | MDoExpr <- ctxt
- = do { (ss,zs) <- repLSts sts;
- e' <- repMDoE (nonEmptyCoreList zs);
- wrapGenSyms ss e' }
-
- | otherwise
- = notHandled "monad comprehension and [: :]" (ppr e)
-
-repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
-repE (ExplicitTuple _ es boxity) =
- let tupArgToCoreExp :: LHsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp)))
- tupArgToCoreExp (L _ a)
- | (Present _ e) <- a = do { e' <- repLE e
- ; coreJustM expTyConName e' }
- | otherwise = coreNothingM expTyConName
-
- in do { args <- mapM tupArgToCoreExp es
- ; expTy <- wrapName expTyConName
- ; let maybeExpQTy = mkTyConApp maybeTyCon [expTy]
- listArg = coreList' maybeExpQTy args
- ; if isBoxed boxity
- then repTup listArg
- else repUnboxedTup listArg }
-
-repE (ExplicitSum _ alt arity e)
- = do { e1 <- repLE e
- ; repUnboxedSum e1 alt arity }
-
-repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
- = do { x <- lookupLOcc c;
- fs <- repFields flds;
- repRecCon x fs }
-repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
- = do { x <- repLE e;
- fs <- repUpdFields flds;
- repRecUpd x fs }
-
-repE (ExprWithTySig _ e ty)
- = do { e1 <- repLE e
- ; t1 <- repHsSigWcType ty
- ; repSigExp e1 t1 }
-
-repE (ArithSeq _ _ aseq) =
- case aseq of
- From e -> do { ds1 <- repLE e; repFrom ds1 }
- FromThen e1 e2 -> do
- ds1 <- repLE e1
- ds2 <- repLE e2
- repFromThen ds1 ds2
- FromTo e1 e2 -> do
- ds1 <- repLE e1
- ds2 <- repLE e2
- repFromTo ds1 ds2
- FromThenTo e1 e2 e3 -> do
- ds1 <- repLE e1
- ds2 <- repLE e2
- ds3 <- repLE e3
- repFromThenTo ds1 ds2 ds3
-
-repE (HsSpliceE _ splice) = repSplice splice
-repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC
-repE (HsUnboundVar _ uv) = do
- occ <- occNameLit uv
- sname <- repNameS occ
- repUnboundVar sname
-
-repE e@(HsPragE _ HsPragCore {} _) = notHandled "Core annotations" (ppr e)
-repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e)
-repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e)
-repE (XExpr nec) = noExtCon nec
-repE e = notHandled "Expression form" (ppr e)
-
------------------------------------------------------------------------------
--- Building representations of auxiliary structures like Match, Clause, Stmt,
-
-repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match))
-repMatchTup (L _ (Match { m_pats = [p]
- , m_grhss = GRHSs _ guards (L _ wheres) })) =
- do { ss1 <- mkGenSyms (collectPatBinders p)
- ; addBinds ss1 $ do {
- ; p1 <- repLP p
- ; (ss2,ds) <- repBinds wheres
- ; addBinds ss2 $ do {
- ; gs <- repGuards guards
- ; match <- repMatch p1 gs ds
- ; wrapGenSyms (ss1++ss2) match }}}
-repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
-
-repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause))
-repClauseTup (L _ (Match { m_pats = ps
- , m_grhss = GRHSs _ guards (L _ wheres) })) =
- do { ss1 <- mkGenSyms (collectPatsBinders ps)
- ; addBinds ss1 $ do {
- ps1 <- repLPs ps
- ; (ss2,ds) <- repBinds wheres
- ; addBinds ss2 $ do {
- gs <- repGuards guards
- ; clause <- repClause ps1 gs ds
- ; wrapGenSyms (ss1++ss2) clause }}}
-repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec
-repClauseTup (L _ (XMatch nec)) = noExtCon nec
-
-repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> MetaM (Core (M TH.Body))
-repGuards [L _ (GRHS _ [] e)]
- = do {a <- repLE e; repNormal a }
-repGuards other
- = do { zs <- mapM repLGRHS other
- ; let (xs, ys) = unzip zs
- ; gd <- repGuarded (nonEmptyCoreList ys)
- ; wrapGenSyms (concat xs) gd }
-
-repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
- -> MetaM ([GenSymBind], (Core (M (TH.Guard, TH.Exp))))
-repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
- = do { guarded <- repLNormalGE e1 e2
- ; return ([], guarded) }
-repLGRHS (L _ (GRHS _ ss rhs))
- = do { (gs, ss') <- repLSts ss
- ; rhs' <- addBinds gs $ repLE rhs
- ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
- ; return (gs, guarded) }
-repLGRHS (L _ (XGRHS nec)) = noExtCon nec
-
-repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp])
-repFields (HsRecFields { rec_flds = flds })
- = repListM fieldExpTyConName rep_fld flds
- where
- rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
- -> MetaM (Core (M TH.FieldExp))
- rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
- ; e <- repLE (hsRecFieldArg fld)
- ; repFieldExp fn e }
-
-repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp])
-repUpdFields = repListM fieldExpTyConName rep_fld
- where
- rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp))
- rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
- Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
- ; e <- repLE (hsRecFieldArg fld)
- ; repFieldExp fn e }
- Ambiguous{} -> notHandled "Ambiguous record updates" (ppr fld)
- XAmbiguousFieldOcc nec -> noExtCon nec
-
-
-
------------------------------------------------------------------------------
--- Representing Stmt's is tricky, especially if bound variables
--- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
--- First gensym new names for every variable in any of the patterns.
--- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
--- if variables didn't shadow, the static gensym wouldn't be necessary
--- and we could reuse the original names (x and x).
---
--- do { x'1 <- gensym "x"
--- ; x'2 <- gensym "x"
--- ; doE [ BindSt (pvar x'1) [| f 1 |]
--- , BindSt (pvar x'2) [| f x |]
--- , NoBindSt [| g x |]
--- ]
--- }
-
--- The strategy is to translate a whole list of do-bindings by building a
--- bigger environment, and a bigger set of meta bindings
--- (like: x'1 <- gensym "x" ) and then combining these with the translations
--- of the expressions within the Do
-
------------------------------------------------------------------------------
--- The helper function repSts computes the translation of each sub expression
--- and a bunch of prefix bindings denoting the dynamic renaming.
-
-repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
-repLSts stmts = repSts (map unLoc stmts)
-
-repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
-repSts (BindStmt _ p e _ _ : ss) =
- do { e2 <- repLE e
- ; ss1 <- mkGenSyms (collectPatBinders p)
- ; addBinds ss1 $ do {
- ; p1 <- repLP p;
- ; (ss2,zs) <- repSts ss
- ; z <- repBindSt p1 e2
- ; return (ss1++ss2, z : zs) }}
-repSts (LetStmt _ (L _ bs) : ss) =
- do { (ss1,ds) <- repBinds bs
- ; z <- repLetSt ds
- ; (ss2,zs) <- addBinds ss1 (repSts ss)
- ; return (ss1++ss2, z : zs) }
-repSts (BodyStmt _ e _ _ : ss) =
- do { e2 <- repLE e
- ; z <- repNoBindSt e2
- ; (ss2,zs) <- repSts ss
- ; return (ss2, z : zs) }
-repSts (ParStmt _ stmt_blocks _ _ : ss) =
- do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
- ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
- ss1 = concat ss_s
- ; z <- repParSt stmt_blocks2
- ; (ss2, zs) <- addBinds ss1 (repSts ss)
- ; return (ss1++ss2, z : zs) }
- where
- rep_stmt_block :: ParStmtBlock GhcRn GhcRn
- -> MetaM ([GenSymBind], Core [(M TH.Stmt)])
- rep_stmt_block (ParStmtBlock _ stmts _ _) =
- do { (ss1, zs) <- repSts (map unLoc stmts)
- ; zs1 <- coreListM stmtTyConName zs
- ; return (ss1, zs1) }
- rep_stmt_block (XParStmtBlock nec) = noExtCon nec
-repSts [LastStmt _ e _ _]
- = do { e2 <- repLE e
- ; z <- repNoBindSt e2
- ; return ([], [z]) }
-repSts (stmt@RecStmt{} : ss)
- = do { let binders = collectLStmtsBinders (recS_stmts stmt)
- ; ss1 <- mkGenSyms binders
- -- Bring all of binders in the recursive group into scope for the
- -- whole group.
- ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))
- ; MASSERT(sort ss1 == sort ss1_other)
- ; z <- repRecSt (nonEmptyCoreList rss)
- ; (ss2,zs) <- addBinds ss1 (repSts ss)
- ; return (ss1++ss2, z : zs) }
-repSts (XStmtLR nec : _) = noExtCon nec
-repSts [] = return ([],[])
-repSts other = notHandled "Exotic statement" (ppr other)
-
-
------------------------------------------------------------
--- Bindings
------------------------------------------------------------
-
-repBinds :: HsLocalBinds GhcRn -> MetaM ([GenSymBind], Core [(M TH.Dec)])
-repBinds (EmptyLocalBinds _)
- = do { core_list <- coreListM decTyConName []
- ; return ([], core_list) }
-
-repBinds (HsIPBinds _ (IPBinds _ decs))
- = do { ips <- mapM rep_implicit_param_bind decs
- ; core_list <- coreListM decTyConName
- (de_loc (sort_by_loc ips))
- ; return ([], core_list)
- }
-
-repBinds (HsIPBinds _ (XHsIPBinds nec)) = noExtCon nec
-
-repBinds (HsValBinds _ decs)
- = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }
- -- No need to worry about detailed scopes within
- -- the binding group, because we are talking Names
- -- here, so we can safely treat it as a mutually
- -- recursive group
- -- For hsScopedTvBinders see Note [Scoped type variables in bindings]
- ; ss <- mkGenSyms bndrs
- ; prs <- addBinds ss (rep_val_binds decs)
- ; core_list <- coreListM decTyConName
- (de_loc (sort_by_loc prs))
- ; return (ss, core_list) }
-repBinds (XHsLocalBindsLR nec) = noExtCon nec
-
-rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
- = do { name <- case ename of
- Left (L _ n) -> rep_implicit_param_name n
- Right _ ->
- panic "rep_implicit_param_bind: post typechecking"
- ; rhs' <- repE rhs
- ; ipb <- repImplicitParamBind name rhs'
- ; return (loc, ipb) }
-rep_implicit_param_bind (L _ (XIPBind nec)) = noExtCon nec
-
-rep_implicit_param_name :: HsIPName -> MetaM (Core String)
-rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
-
-rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
--- Assumes: all the binders of the binding are already in the meta-env
-rep_val_binds (XValBindsLR (NValBinds binds sigs))
- = do { core1 <- rep_binds (unionManyBags (map snd binds))
- ; core2 <- rep_sigs sigs
- ; return (core1 ++ core2) }
-rep_val_binds (ValBinds _ _ _)
- = panic "rep_val_binds: ValBinds"
-
-rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_binds = mapM rep_bind . bagToList
-
-rep_bind :: LHsBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
--- Assumes: all the binders of the binding are already in the meta-env
-
--- Note GHC treats declarations of a variable (not a pattern)
--- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
--- with an empty list of patterns
-rep_bind (L loc (FunBind
- { fun_id = fn,
- fun_matches = MG { mg_alts
- = (L _ [L _ (Match
- { m_pats = []
- , m_grhss = GRHSs _ guards (L _ wheres) }
- )]) } }))
- = do { (ss,wherecore) <- repBinds wheres
- ; guardcore <- addBinds ss (repGuards guards)
- ; fn' <- lookupLBinder fn
- ; p <- repPvar fn'
- ; ans <- repVal p guardcore wherecore
- ; ans' <- wrapGenSyms ss ans
- ; return (loc, ans') }
-
-rep_bind (L loc (FunBind { fun_id = fn
- , fun_matches = MG { mg_alts = L _ ms } }))
- = do { ms1 <- mapM repClauseTup ms
- ; fn' <- lookupLBinder fn
- ; ans <- repFun fn' (nonEmptyCoreList ms1)
- ; return (loc, ans) }
-
-rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec
-
-rep_bind (L loc (PatBind { pat_lhs = pat
- , pat_rhs = GRHSs _ guards (L _ wheres) }))
- = do { patcore <- repLP pat
- ; (ss,wherecore) <- repBinds wheres
- ; guardcore <- addBinds ss (repGuards guards)
- ; ans <- repVal patcore guardcore wherecore
- ; ans' <- wrapGenSyms ss ans
- ; return (loc, ans') }
-rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec
-
-rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
- = do { v' <- lookupBinder v
- ; e2 <- repLE e
- ; x <- repNormal e2
- ; patcore <- repPvar v'
- ; empty_decls <- coreListM decTyConName []
- ; ans <- repVal patcore x empty_decls
- ; return (srcLocSpan (getSrcLoc v), ans) }
-
-rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
-rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
- , psb_args = args
- , psb_def = pat
- , psb_dir = dir })))
- = do { syn' <- lookupLBinder syn
- ; dir' <- repPatSynDir dir
- ; ss <- mkGenArgSyms args
- ; patSynD' <- addBinds ss (
- do { args' <- repPatSynArgs args
- ; pat' <- repLP pat
- ; repPatSynD syn' args' dir' pat' })
- ; patSynD'' <- wrapGenArgSyms args ss patSynD'
- ; return (loc, patSynD'') }
- where
- mkGenArgSyms :: HsPatSynDetails (Located Name) -> MetaM [GenSymBind]
- -- for Record Pattern Synonyms we want to conflate the selector
- -- and the pattern-only names in order to provide a nicer TH
- -- API. Whereas inside GHC, record pattern synonym selectors and
- -- their pattern-only bound right hand sides have different names,
- -- we want to treat them the same in TH. This is the reason why we
- -- need an adjusted mkGenArgSyms in the `RecCon` case below.
- mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args)
- mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
- mkGenArgSyms (RecCon fields)
- = do { let pats = map (unLoc . recordPatSynPatVar) fields
- sels = map (unLoc . recordPatSynSelectorId) fields
- ; ss <- mkGenSyms sels
- ; return $ replaceNames (zip sels pats) ss }
-
- replaceNames selsPats genSyms
- = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
- , sel == sel' ]
-
- wrapGenArgSyms :: HsPatSynDetails (Located Name)
- -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec))
- wrapGenArgSyms (RecCon _) _ dec = return dec
- wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
-
-rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec
-rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec
-
-repPatSynD :: Core TH.Name
- -> Core (M TH.PatSynArgs)
- -> Core (M TH.PatSynDir)
- -> Core (M TH.Pat)
- -> MetaM (Core (M TH.Dec))
-repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
- = rep2 patSynDName [syn, args, dir, pat]
-
-repPatSynArgs :: HsPatSynDetails (Located Name) -> MetaM (Core (M TH.PatSynArgs))
-repPatSynArgs (PrefixCon args)
- = do { args' <- repList nameTyConName lookupLOcc args
- ; repPrefixPatSynArgs args' }
-repPatSynArgs (InfixCon arg1 arg2)
- = do { arg1' <- lookupLOcc arg1
- ; arg2' <- lookupLOcc arg2
- ; repInfixPatSynArgs arg1' arg2' }
-repPatSynArgs (RecCon fields)
- = do { sels' <- repList nameTyConName lookupLOcc sels
- ; repRecordPatSynArgs sels' }
- where sels = map recordPatSynSelectorId fields
-
-repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs))
-repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
-
-repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> MetaM (Core (M TH.PatSynArgs))
-repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
-
-repRecordPatSynArgs :: Core [TH.Name]
- -> MetaM (Core (M TH.PatSynArgs))
-repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
-
-repPatSynDir :: HsPatSynDir GhcRn -> MetaM (Core (M TH.PatSynDir))
-repPatSynDir Unidirectional = rep2 unidirPatSynName []
-repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
-repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) }))
- = do { clauses' <- mapM repClauseTup clauses
- ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
-repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec
-
-repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir))
-repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
-
-
------------------------------------------------------------------------------
--- Since everything in a Bind is mutually recursive we need rename all
--- all the variables simultaneously. For example:
--- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
--- do { f'1 <- gensym "f"
--- ; g'2 <- gensym "g"
--- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
--- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
--- ]}
--- This requires collecting the bindings (f'1 <- gensym "f"), and the
--- environment ( f |-> f'1 ) from each binding, and then unioning them
--- together. As we do this we collect GenSymBinds's which represent the renamed
--- variables bound by the Bindings. In order not to lose track of these
--- representations we build a shadow datatype MB with the same structure as
--- MonoBinds, but which has slots for the representations
-
-
------------------------------------------------------------------------------
--- GHC allows a more general form of lambda abstraction than specified
--- by Haskell 98. In particular it allows guarded lambda's like :
--- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
--- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
--- (\ p1 .. pn -> exp) by causing an error.
-
-repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp))
-repLambda (L _ (Match { m_pats = ps
- , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
- (L _ (EmptyLocalBinds _)) } ))
- = do { let bndrs = collectPatsBinders ps ;
- ; ss <- mkGenSyms bndrs
- ; lam <- addBinds ss (
- do { xs <- repLPs ps; body <- repLE e; repLam xs body })
- ; wrapGenSyms ss lam }
-repLambda (L _ (Match { m_grhss = GRHSs _ [L _ (GRHS _ [] _)]
- (L _ (XHsLocalBindsLR nec)) } ))
- = noExtCon nec
-
-repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m)
-
-
------------------------------------------------------------------------------
--- Patterns
--- repP deals with patterns. It assumes that we have already
--- walked over the pattern(s) once to collect the binders, and
--- have extended the environment. So every pattern-bound
--- variable should already appear in the environment.
-
--- Process a list of patterns
-repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)])
-repLPs ps = repListM patTyConName repLP ps
-
-repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
-repLP p = repP (unLoc p)
-
-repP :: Pat GhcRn -> MetaM (Core (M TH.Pat))
-repP (WildPat _) = repPwild
-repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 }
-repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' }
-repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 }
-repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 }
-repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p
- ; repPaspat x' p1 }
-repP (ParPat _ p) = repLP p
-repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs }
-repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps)
- ; e' <- repE e
- ; repPview e' p}
-repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps)
-repP (TuplePat _ ps boxed)
- | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
- | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
-repP (SumPat _ p alt arity) = do { p1 <- repLP p
- ; repPunboxedSum p1 alt arity }
-repP (ConPatIn dc details)
- = do { con_str <- lookupLOcc dc
- ; case details of
- PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
- RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)
- ; repPrec con_str fps }
- InfixCon p1 p2 -> do { p1' <- repLP p1;
- p2' <- repLP p2;
- repPinfix p1' con_str p2' }
- }
- where
- rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat)))
- rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
- ; MkC p <- repLP (hsRecFieldArg fld)
- ; rep2 fieldPatName [v,p] }
-
-repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l
- ; repPlit a }
-repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
-repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
-repP (SigPat _ p t) = do { p' <- repLP p
- ; t' <- repLTy (hsSigWcType t)
- ; repPsig p' t' }
-repP (SplicePat _ splice) = repSplice splice
-repP (XPat nec) = noExtCon nec
-repP other = notHandled "Exotic pattern" (ppr other)
-
-----------------------------------------------------------
--- Declaration ordering helpers
-
-sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
-sort_by_loc xs = sortBy comp xs
- where comp x y = compare (fst x) (fst y)
-
-de_loc :: [(a, b)] -> [b]
-de_loc = map snd
-
-----------------------------------------------------------
--- The meta-environment
-
--- A name/identifier association for fresh names of locally bound entities
-type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
- -- I.e. (x, x_id) means
- -- let x_id = gensym "x" in ...
-
--- Generate a fresh name for a locally bound entity
-
-mkGenSyms :: [Name] -> MetaM [GenSymBind]
--- We can use the existing name. For example:
--- [| \x_77 -> x_77 + x_77 |]
--- desugars to
--- do { x_77 <- genSym "x"; .... }
--- We use the same x_77 in the desugared program, but with the type Bndr
--- instead of Int
---
--- We do make it an Internal name, though (hence localiseName)
---
--- Nevertheless, it's monadic because we have to generate nameTy
-mkGenSyms ns = do { var_ty <- lookupType nameTyConName
- ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
-
-
-addBinds :: [GenSymBind] -> MetaM a -> MetaM a
--- Add a list of fresh names for locally bound entities to the
--- meta environment (which is part of the state carried around
--- by the desugarer monad)
-addBinds bs m = mapReaderT (dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs])) m
-
--- Look up a locally bound name
---
-lookupLBinder :: Located Name -> MetaM (Core TH.Name)
-lookupLBinder n = lookupBinder (unLoc n)
-
-lookupBinder :: Name -> MetaM (Core TH.Name)
-lookupBinder = lookupOcc
- -- Binders are brought into scope before the pattern or what-not is
- -- desugared. Moreover, in instance declaration the binder of a method
- -- will be the selector Id and hence a global; so we need the
- -- globalVar case of lookupOcc
-
--- Look up a name that is either locally bound or a global name
---
--- * If it is a global name, generate the "original name" representation (ie,
--- the <module>:<name> form) for the associated entity
---
-lookupLOcc :: Located Name -> MetaM (Core TH.Name)
--- Lookup an occurrence; it can't be a splice.
--- Use the in-scope bindings if they exist
-lookupLOcc n = lookupOcc (unLoc n)
-
-lookupOcc :: Name -> MetaM (Core TH.Name)
-lookupOcc = lift . lookupOccDsM
-
-lookupOccDsM :: Name -> DsM (Core TH.Name)
-lookupOccDsM n
- = do { mb_val <- dsLookupMetaEnv n ;
- case mb_val of
- Nothing -> globalVar n
- Just (DsBound x) -> return (coreVar x)
- Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
- }
-
-globalVar :: Name -> DsM (Core TH.Name)
--- Not bound by the meta-env
--- Could be top-level; or could be local
--- f x = $(g [| x |])
--- Here the x will be local
-globalVar name
- | isExternalName name
- = do { MkC mod <- coreStringLit name_mod
- ; MkC pkg <- coreStringLit name_pkg
- ; MkC occ <- nameLit name
- ; rep2_nwDsM mk_varg [pkg,mod,occ] }
- | otherwise
- = do { MkC occ <- nameLit name
- ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))
- ; rep2_nwDsM mkNameLName [occ,uni] }
- where
- mod = ASSERT( isExternalName name) nameModule name
- name_mod = moduleNameString (moduleName mod)
- name_pkg = unitIdString (moduleUnitId mod)
- name_occ = nameOccName name
- mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
- | OccName.isVarOcc name_occ = mkNameG_vName
- | OccName.isTcOcc name_occ = mkNameG_tcName
- | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
-
-lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp))
- -> MetaM Type -- The type
-lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ;
- return (mkTyConApp tc []) }
-
-wrapGenSyms :: [GenSymBind]
- -> Core (M a) -> MetaM (Core (M a))
--- wrapGenSyms [(nm1,id1), (nm2,id2)] y
--- --> bindQ (gensym nm1) (\ id1 ->
--- bindQ (gensym nm2 (\ id2 ->
--- y))
-
-wrapGenSyms binds body@(MkC b)
- = do { var_ty <- lookupType nameTyConName
- ; go var_ty binds }
- where
- (_, [elt_ty]) = tcSplitAppTys (exprType b)
- -- b :: m a, so we can get the type 'a' by looking at the
- -- argument type. NB: this relies on Q being a data/newtype,
- -- not a type synonym
-
- go _ [] = return body
- go var_ty ((name,id) : binds)
- = do { MkC body' <- go var_ty binds
- ; lit_str <- lift $ nameLit name
- ; gensym_app <- repGensym lit_str
- ; repBindM var_ty elt_ty
- gensym_app (MkC (Lam id body')) }
-
-nameLit :: Name -> DsM (Core String)
-nameLit n = coreStringLit (occNameString (nameOccName n))
-
-occNameLit :: OccName -> MetaM (Core String)
-occNameLit name = coreStringLit (occNameString name)
-
-
--- %*********************************************************************
--- %* *
--- Constructing code
--- %* *
--- %*********************************************************************
-
------------------------------------------------------------------------------
--- PHANTOM TYPES for consistency. In order to make sure we do this correct
--- we invent a new datatype which uses phantom types.
-
-newtype Core a = MkC CoreExpr
-unC :: Core a -> CoreExpr
-unC (MkC x) = x
-
-type family NotM a where
- NotM (M _) = TypeError ('Text ("rep2_nw must not produce something of overloaded type"))
- NotM _other = (() :: Constraint)
-
-rep2M :: Name -> [CoreExpr] -> MetaM (Core (M a))
-rep2 :: Name -> [CoreExpr] -> MetaM (Core (M a))
-rep2_nw :: NotM a => Name -> [CoreExpr] -> MetaM (Core a)
-rep2_nwDsM :: NotM a => Name -> [CoreExpr] -> DsM (Core a)
-rep2 = rep2X lift (asks quoteWrapper)
-rep2M = rep2X lift (asks monadWrapper)
-rep2_nw n xs = lift (rep2_nwDsM n xs)
-rep2_nwDsM = rep2X id (return id)
-
-rep2X :: Monad m => (forall z . DsM z -> m z)
- -> m (CoreExpr -> CoreExpr)
- -> Name
- -> [ CoreExpr ]
- -> m (Core a)
-rep2X lift_dsm get_wrap n xs = do
- { rep_id <- lift_dsm $ dsLookupGlobalId n
- ; wrap <- get_wrap
- ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) }
-
-
-dataCon' :: Name -> [CoreExpr] -> MetaM (Core a)
-dataCon' n args = do { id <- lift $ dsLookupDataCon n
- ; return $ MkC $ mkCoreConApps id args }
-
-dataCon :: Name -> MetaM (Core a)
-dataCon n = dataCon' n []
-
-
--- %*********************************************************************
--- %* *
--- The 'smart constructors'
--- %* *
--- %*********************************************************************
-
---------------- Patterns -----------------
-repPlit :: Core TH.Lit -> MetaM (Core (M TH.Pat))
-repPlit (MkC l) = rep2 litPName [l]
-
-repPvar :: Core TH.Name -> MetaM (Core (M TH.Pat))
-repPvar (MkC s) = rep2 varPName [s]
-
-repPtup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
-repPtup (MkC ps) = rep2 tupPName [ps]
-
-repPunboxedTup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
-repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
-
-repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat))
--- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
-repPunboxedSum (MkC p) alt arity
- = do { dflags <- getDynFlags
- ; rep2 unboxedSumPName [ p
- , mkIntExprInt dflags alt
- , mkIntExprInt dflags arity ] }
-
-repPcon :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
-repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
-
-repPrec :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat))
-repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
-
-repPinfix :: Core (M TH.Pat) -> Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
-repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
-
-repPtilde :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
-repPtilde (MkC p) = rep2 tildePName [p]
-
-repPbang :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
-repPbang (MkC p) = rep2 bangPName [p]
-
-repPaspat :: Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
-repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
-
-repPwild :: MetaM (Core (M TH.Pat))
-repPwild = rep2 wildPName []
-
-repPlist :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
-repPlist (MkC ps) = rep2 listPName [ps]
-
-repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
-repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
-
-repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat))
-repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
-
---------------- Expressions -----------------
-repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp))
-repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
- | otherwise = repVar str
-
-repVar :: Core TH.Name -> MetaM (Core (M TH.Exp))
-repVar (MkC s) = rep2 varEName [s]
-
-repCon :: Core TH.Name -> MetaM (Core (M TH.Exp))
-repCon (MkC s) = rep2 conEName [s]
-
-repLit :: Core TH.Lit -> MetaM (Core (M TH.Exp))
-repLit (MkC c) = rep2 litEName [c]
-
-repApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repApp (MkC x) (MkC y) = rep2 appEName [x,y]
-
-repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
-repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
-
-repLam :: Core [(M TH.Pat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
-
-repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
-repLamCase (MkC ms) = rep2 lamCaseEName [ms]
-
-repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))
-repTup (MkC es) = rep2 tupEName [es]
-
-repUnboxedTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))
-repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
-
-repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp))
--- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
-repUnboxedSum (MkC e) alt arity
- = do { dflags <- getDynFlags
- ; rep2 unboxedSumEName [ e
- , mkIntExprInt dflags alt
- , mkIntExprInt dflags arity ] }
-
-repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
-
-repMultiIf :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Exp))
-repMultiIf (MkC alts) = rep2 multiIfEName [alts]
-
-repLetE :: Core [(M TH.Dec)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
-
-repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
-repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
-
-repDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
-repDoE (MkC ss) = rep2 doEName [ss]
-
-repMDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
-repMDoE (MkC ss) = rep2 mdoEName [ss]
-
-repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
-repComp (MkC ss) = rep2 compEName [ss]
-
-repListExp :: Core [(M TH.Exp)] -> MetaM (Core (M TH.Exp))
-repListExp (MkC es) = rep2 listEName [es]
-
-repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
-repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
-
-repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp))
-repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
-
-repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp))
-repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
-
-repFieldExp :: Core TH.Name -> Core (M TH.Exp) -> MetaM (Core (M TH.FieldExp))
-repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
-
-repInfixApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
-
-repSectionL :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
-
-repSectionR :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
-
-repImplicitParamVar :: Core String -> MetaM (Core (M TH.Exp))
-repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
-
------------- Right hand sides (guarded expressions) ----
-repGuarded :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Body))
-repGuarded (MkC pairs) = rep2 guardedBName [pairs]
-
-repNormal :: Core (M TH.Exp) -> MetaM (Core (M TH.Body))
-repNormal (MkC e) = rep2 normalBName [e]
-
------------- Guards ----
-repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn
- -> MetaM (Core (M (TH.Guard, TH.Exp)))
-repLNormalGE g e = do g' <- repLE g
- e' <- repLE e
- repNormalGE g' e'
-
-repNormalGE :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))
-repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
-
-repPatGE :: Core [(M TH.Stmt)] -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))
-repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
-
-------------- Stmts -------------------
-repBindSt :: Core (M TH.Pat) -> Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))
-repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
-
-repLetSt :: Core [(M TH.Dec)] -> MetaM (Core (M TH.Stmt))
-repLetSt (MkC ds) = rep2 letSName [ds]
-
-repNoBindSt :: Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))
-repNoBindSt (MkC e) = rep2 noBindSName [e]
-
-repParSt :: Core [[(M TH.Stmt)]] -> MetaM (Core (M TH.Stmt))
-repParSt (MkC sss) = rep2 parSName [sss]
-
-repRecSt :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Stmt))
-repRecSt (MkC ss) = rep2 recSName [ss]
-
--------------- Range (Arithmetic sequences) -----------
-repFrom :: Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repFrom (MkC x) = rep2 fromEName [x]
-
-repFromThen :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
-
-repFromTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
-
-repFromThenTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
-
------------- Match and Clause Tuples -----------
-repMatch :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Match))
-repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
-
-repClause :: Core [(M TH.Pat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause))
-repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
-
--------------- Dec -----------------------------
-repVal :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
-repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
-
-repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec))
-repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
-
-repData :: Core (M TH.Cxt) -> Core TH.Name
- -> Either (Core [(M TH.TyVarBndr)])
- (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))
- -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause]
- -> MetaM (Core (M TH.Dec))
-repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
- = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
-repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
- (MkC derivs)
- = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
-
-repNewtype :: Core (M TH.Cxt) -> Core TH.Name
- -> Either (Core [(M TH.TyVarBndr)])
- (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))
- -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause]
- -> MetaM (Core (M TH.Dec))
-repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
- (MkC derivs)
- = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
-repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)
- (MkC derivs)
- = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]
-
-repTySyn :: Core TH.Name -> Core [(M TH.TyVarBndr)]
- -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))
-repTySyn (MkC nm) (MkC tvs) (MkC rhs)
- = rep2 tySynDName [nm, tvs, rhs]
-
-repInst :: Core (Maybe TH.Overlap) ->
- Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
-repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
- [o, cxt, ty, ds]
-
-repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
- -> MetaM (Core (Maybe (M TH.DerivStrategy)))
-repDerivStrategy mds =
- case mds of
- Nothing -> nothing
- Just ds ->
- case unLoc ds of
- StockStrategy -> just =<< repStockStrategy
- AnyclassStrategy -> just =<< repAnyclassStrategy
- NewtypeStrategy -> just =<< repNewtypeStrategy
- ViaStrategy ty -> do ty' <- repLTy (hsSigType ty)
- via_strat <- repViaStrategy ty'
- just via_strat
- where
- nothing = coreNothingM derivStrategyTyConName
- just = coreJustM derivStrategyTyConName
-
-repStockStrategy :: MetaM (Core (M TH.DerivStrategy))
-repStockStrategy = rep2 stockStrategyName []
-
-repAnyclassStrategy :: MetaM (Core (M TH.DerivStrategy))
-repAnyclassStrategy = rep2 anyclassStrategyName []
-
-repNewtypeStrategy :: MetaM (Core (M TH.DerivStrategy))
-repNewtypeStrategy = rep2 newtypeStrategyName []
-
-repViaStrategy :: Core (M TH.Type) -> MetaM (Core (M TH.DerivStrategy))
-repViaStrategy (MkC t) = rep2 viaStrategyName [t]
-
-repOverlap :: Maybe OverlapMode -> MetaM (Core (Maybe TH.Overlap))
-repOverlap mb =
- case mb of
- Nothing -> nothing
- Just o ->
- case o of
- NoOverlap _ -> nothing
- Overlappable _ -> just =<< dataCon overlappableDataConName
- Overlapping _ -> just =<< dataCon overlappingDataConName
- Overlaps _ -> just =<< dataCon overlapsDataConName
- Incoherent _ -> just =<< dataCon incoherentDataConName
- where
- nothing = coreNothing overlapTyConName
- just = coreJust overlapTyConName
-
-
-repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M TH.TyVarBndr)]
- -> Core [TH.FunDep] -> Core [(M TH.Dec)]
- -> MetaM (Core (M TH.Dec))
-repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
- = rep2 classDName [cxt, cls, tvs, fds, ds]
-
-repDeriv :: Core (Maybe (M TH.DerivStrategy))
- -> Core (M TH.Cxt) -> Core (M TH.Type)
- -> MetaM (Core (M TH.Dec))
-repDeriv (MkC ds) (MkC cxt) (MkC ty)
- = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
-
-repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
- -> Core TH.Phases -> MetaM (Core (M TH.Dec))
-repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
- = rep2 pragInlDName [nm, inline, rm, phases]
-
-repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases
- -> MetaM (Core (M TH.Dec))
-repPragSpec (MkC nm) (MkC ty) (MkC phases)
- = rep2 pragSpecDName [nm, ty, phases]
-
-repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline
- -> Core TH.Phases -> MetaM (Core (M TH.Dec))
-repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
- = rep2 pragSpecInlDName [nm, ty, inline, phases]
-
-repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec))
-repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
-
-repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec))
-repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
-
-repPragRule :: Core String -> Core (Maybe [(M TH.TyVarBndr)])
- -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp)
- -> Core TH.Phases -> MetaM (Core (M TH.Dec))
-repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
- = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
-
-repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
-repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
-
-repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec))
-repTySynInst (MkC eqn)
- = rep2 tySynInstDName [eqn]
-
-repDataFamilyD :: Core TH.Name -> Core [(M TH.TyVarBndr)]
- -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec))
-repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
- = rep2 dataFamilyDName [nm, tvs, kind]
-
-repOpenFamilyD :: Core TH.Name
- -> Core [(M TH.TyVarBndr)]
- -> Core (M TH.FamilyResultSig)
- -> Core (Maybe TH.InjectivityAnn)
- -> MetaM (Core (M TH.Dec))
-repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
- = rep2 openTypeFamilyDName [nm, tvs, result, inj]
-
-repClosedFamilyD :: Core TH.Name
- -> Core [(M TH.TyVarBndr)]
- -> Core (M TH.FamilyResultSig)
- -> Core (Maybe TH.InjectivityAnn)
- -> Core [(M TH.TySynEqn)]
- -> MetaM (Core (M TH.Dec))
-repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
- = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
-
-repTySynEqn :: Core (Maybe [(M TH.TyVarBndr)]) ->
- Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn))
-repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
- = rep2 tySynEqnName [mb_bndrs, lhs, rhs]
-
-repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> MetaM (Core (M TH.Dec))
-repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
-
-repFunDep :: Core [TH.Name] -> Core [TH.Name] -> MetaM (Core TH.FunDep)
-repFunDep (MkC xs) (MkC ys) = rep2_nw funDepName [xs, ys]
-
-repProto :: Name -> Core TH.Name -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))
-repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
-
-repImplicitParamBind :: Core String -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
-repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
-
-repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt))
-repCtxt (MkC tys) = rep2 cxtName [tys]
-
-repDataCon :: Located Name
- -> HsConDeclDetails GhcRn
- -> MetaM (Core (M TH.Con))
-repDataCon con details
- = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
- repConstr details Nothing [con']
-
-repGadtDataCons :: [Located Name]
- -> HsConDeclDetails GhcRn
- -> LHsType GhcRn
- -> MetaM (Core (M TH.Con))
-repGadtDataCons cons details res_ty
- = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
- repConstr details (Just res_ty) cons'
-
--- Invariant:
--- * for plain H98 data constructors second argument is Nothing and third
--- argument is a singleton list
--- * for GADTs data constructors second argument is (Just return_type) and
--- third argument is a non-empty list
-repConstr :: HsConDeclDetails GhcRn
- -> Maybe (LHsType GhcRn)
- -> [Core TH.Name]
- -> MetaM (Core (M TH.Con))
-repConstr (PrefixCon ps) Nothing [con]
- = do arg_tys <- repListM bangTypeTyConName repBangTy ps
- rep2 normalCName [unC con, unC arg_tys]
-
-repConstr (PrefixCon ps) (Just res_ty) cons
- = do arg_tys <- repListM bangTypeTyConName repBangTy ps
- res_ty' <- repLTy res_ty
- rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
-
-repConstr (RecCon ips) resTy cons
- = do args <- concatMapM rep_ip (unLoc ips)
- arg_vtys <- coreListM varBangTypeTyConName args
- case resTy of
- Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
- Just res_ty -> do
- res_ty' <- repLTy res_ty
- rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
- unC res_ty']
-
- where
- rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
-
- rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
- rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n)
- ; MkC ty <- repBangTy t
- ; rep2 varBangTypeName [v,ty] }
-
-repConstr (InfixCon st1 st2) Nothing [con]
- = do arg1 <- repBangTy st1
- arg2 <- repBangTy st2
- rep2 infixCName [unC arg1, unC con, unC arg2]
-
-repConstr (InfixCon {}) (Just _) _ =
- panic "repConstr: infix GADT constructor should be in a PrefixCon"
-repConstr _ _ _ =
- panic "repConstr: invariant violated"
-
------------- Types -------------------
-
-repTForall :: Core [(M TH.TyVarBndr)] -> Core (M TH.Cxt) -> Core (M TH.Type)
- -> MetaM (Core (M TH.Type))
-repTForall (MkC tvars) (MkC ctxt) (MkC ty)
- = rep2 forallTName [tvars, ctxt, ty]
-
-repTForallVis :: Core [(M TH.TyVarBndr)] -> Core (M TH.Type)
- -> MetaM (Core (M TH.Type))
-repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty]
-
-repTvar :: Core TH.Name -> MetaM (Core (M TH.Type))
-repTvar (MkC s) = rep2 varTName [s]
-
-repTapp :: Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.Type))
-repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
-
-repTappKind :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))
-repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]
-
-repTapps :: Core (M TH.Type) -> [Core (M TH.Type)] -> MetaM (Core (M TH.Type))
-repTapps f [] = return f
-repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
-
-repTSig :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))
-repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
-
-repTequality :: MetaM (Core (M TH.Type))
-repTequality = rep2 equalityTName []
-
-repTPromotedList :: [Core (M TH.Type)] -> MetaM (Core (M TH.Type))
-repTPromotedList [] = repPromotedNilTyCon
-repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
- ; f <- repTapp tcon t
- ; t' <- repTPromotedList ts
- ; repTapp f t'
- }
-
-repTLit :: Core (M TH.TyLit) -> MetaM (Core (M TH.Type))
-repTLit (MkC lit) = rep2 litTName [lit]
-
-repTWildCard :: MetaM (Core (M TH.Type))
-repTWildCard = rep2 wildCardTName []
-
-repTImplicitParam :: Core String -> Core (M TH.Type) -> MetaM (Core (M TH.Type))
-repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
-
-repTStar :: MetaM (Core (M TH.Type))
-repTStar = rep2 starKName []
-
-repTConstraint :: MetaM (Core (M TH.Type))
-repTConstraint = rep2 constraintKName []
-
---------- Type constructors --------------
-
-repNamedTyCon :: Core TH.Name -> MetaM (Core (M TH.Type))
-repNamedTyCon (MkC s) = rep2 conTName [s]
-
-repTInfix :: Core (M TH.Type) -> Core TH.Name -> Core (M TH.Type)
- -> MetaM (Core (M TH.Type))
-repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]
-
-repTupleTyCon :: Int -> MetaM (Core (M TH.Type))
--- Note: not Core Int; it's easier to be direct here
-repTupleTyCon i = do dflags <- getDynFlags
- rep2 tupleTName [mkIntExprInt dflags i]
-
-repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type))
--- Note: not Core Int; it's easier to be direct here
-repUnboxedTupleTyCon i = do dflags <- getDynFlags
- rep2 unboxedTupleTName [mkIntExprInt dflags i]
-
-repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type))
--- Note: not Core TH.SumArity; it's easier to be direct here
-repUnboxedSumTyCon arity = do dflags <- getDynFlags
- rep2 unboxedSumTName [mkIntExprInt dflags arity]
-
-repArrowTyCon :: MetaM (Core (M TH.Type))
-repArrowTyCon = rep2 arrowTName []
-
-repListTyCon :: MetaM (Core (M TH.Type))
-repListTyCon = rep2 listTName []
-
-repPromotedDataCon :: Core TH.Name -> MetaM (Core (M TH.Type))
-repPromotedDataCon (MkC s) = rep2 promotedTName [s]
-
-repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type))
-repPromotedTupleTyCon i = do dflags <- getDynFlags
- rep2 promotedTupleTName [mkIntExprInt dflags i]
-
-repPromotedNilTyCon :: MetaM (Core (M TH.Type))
-repPromotedNilTyCon = rep2 promotedNilTName []
-
-repPromotedConsTyCon :: MetaM (Core (M TH.Type))
-repPromotedConsTyCon = rep2 promotedConsTName []
-
------------- TyVarBndrs -------------------
-
-repPlainTV :: Core TH.Name -> MetaM (Core (M TH.TyVarBndr))
-repPlainTV (MkC nm) = rep2 plainTVName [nm]
-
-repKindedTV :: Core TH.Name -> Core (M TH.Kind) -> MetaM (Core (M TH.TyVarBndr))
-repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
-
-----------------------------------------------------------
--- Type family result signature
-
-repNoSig :: MetaM (Core (M TH.FamilyResultSig))
-repNoSig = rep2 noSigName []
-
-repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig))
-repKindSig (MkC ki) = rep2 kindSigName [ki]
-
-repTyVarSig :: Core (M TH.TyVarBndr) -> MetaM (Core (M TH.FamilyResultSig))
-repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
-
-----------------------------------------------------------
--- Literals
-
-repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit)
-repLiteral (HsStringPrim _ bs)
- = do dflags <- getDynFlags
- word8_ty <- lookupType word8TyConName
- let w8s = unpack bs
- w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
- [mkWordLit dflags (toInteger w8)]) w8s
- rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr]
-repLiteral lit
- = do lit' <- case lit of
- HsIntPrim _ i -> mk_integer i
- HsWordPrim _ w -> mk_integer w
- HsInt _ i -> mk_integer (il_value i)
- HsFloatPrim _ r -> mk_rational r
- HsDoublePrim _ r -> mk_rational r
- HsCharPrim _ c -> mk_char c
- _ -> return lit
- lit_expr <- lift $ dsLit lit'
- case mb_lit_name of
- Just lit_name -> rep2_nw lit_name [lit_expr]
- Nothing -> notHandled "Exotic literal" (ppr lit)
- where
- mb_lit_name = case lit of
- HsInteger _ _ _ -> Just integerLName
- HsInt _ _ -> Just integerLName
- HsIntPrim _ _ -> Just intPrimLName
- HsWordPrim _ _ -> Just wordPrimLName
- HsFloatPrim _ _ -> Just floatPrimLName
- HsDoublePrim _ _ -> Just doublePrimLName
- HsChar _ _ -> Just charLName
- HsCharPrim _ _ -> Just charPrimLName
- HsString _ _ -> Just stringLName
- HsRat _ _ _ -> Just rationalLName
- _ -> Nothing
-
-mk_integer :: Integer -> MetaM (HsLit GhcRn)
-mk_integer i = do integer_ty <- lookupType integerTyConName
- return $ HsInteger NoSourceText i integer_ty
-
-mk_rational :: FractionalLit -> MetaM (HsLit GhcRn)
-mk_rational r = do rat_ty <- lookupType rationalTyConName
- return $ HsRat noExtField r rat_ty
-mk_string :: FastString -> MetaM (HsLit GhcRn)
-mk_string s = return $ HsString NoSourceText s
-
-mk_char :: Char -> MetaM (HsLit GhcRn)
-mk_char c = return $ HsChar NoSourceText c
-
-repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit)
-repOverloadedLiteral (OverLit { ol_val = val})
- = do { lit <- mk_lit val; repLiteral lit }
- -- The type Rational will be in the environment, because
- -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
- -- and rationalL is sucked in when any TH stuff is used
-repOverloadedLiteral (XOverLit nec) = noExtCon nec
-
-mk_lit :: OverLitVal -> MetaM (HsLit GhcRn)
-mk_lit (HsIntegral i) = mk_integer (il_value i)
-mk_lit (HsFractional f) = mk_rational f
-mk_lit (HsIsString _ s) = mk_string s
-
-repNameS :: Core String -> MetaM (Core TH.Name)
-repNameS (MkC name) = rep2_nw mkNameSName [name]
-
---------------- Miscellaneous -------------------
-
-repGensym :: Core String -> MetaM (Core (M TH.Name))
-repGensym (MkC lit_str) = rep2 newNameName [lit_str]
-
-repBindM :: Type -> Type -- a and b
- -> Core (M a) -> Core (a -> M b) -> MetaM (Core (M b))
-repBindM ty_a ty_b (MkC x) (MkC y)
- = rep2M bindMName [Type ty_a, Type ty_b, x, y]
-
-repSequenceM :: Type -> Core [M a] -> MetaM (Core (M [a]))
-repSequenceM ty_a (MkC list)
- = rep2M sequenceQName [Type ty_a, list]
-
-repUnboundVar :: Core TH.Name -> MetaM (Core (M TH.Exp))
-repUnboundVar (MkC name) = rep2 unboundVarEName [name]
-
-repOverLabel :: FastString -> MetaM (Core (M TH.Exp))
-repOverLabel fs = do
- (MkC s) <- coreStringLit $ unpackFS fs
- rep2 labelEName [s]
-
-
------------- Lists -------------------
--- turn a list of patterns into a single pattern matching a list
-
-repList :: Name -> (a -> MetaM (Core b))
- -> [a] -> MetaM (Core [b])
-repList tc_name f args
- = do { args1 <- mapM f args
- ; coreList tc_name args1 }
-
--- Create a list of m a values
-repListM :: Name -> (a -> MetaM (Core b))
- -> [a] -> MetaM (Core [b])
-repListM tc_name f args
- = do { ty <- wrapName tc_name
- ; args1 <- mapM f args
- ; return $ coreList' ty args1 }
-
-coreListM :: Name -> [Core a] -> MetaM (Core [a])
-coreListM tc as = repListM tc return as
-
-coreList :: Name -- Of the TyCon of the element type
- -> [Core a] -> MetaM (Core [a])
-coreList tc_name es
- = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
-
-coreList' :: Type -- The element type
- -> [Core a] -> Core [a]
-coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
-
-nonEmptyCoreList :: [Core a] -> Core [a]
- -- The list must be non-empty so we can get the element type
- -- Otherwise use coreList
-nonEmptyCoreList [] = panic "coreList: empty argument"
-nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
-
-
-coreStringLit :: MonadThings m => String -> m (Core String)
-coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
-
-------------------- Maybe ------------------
-
-repMaybe :: Name -> (a -> MetaM (Core b))
- -> Maybe a -> MetaM (Core (Maybe b))
-repMaybe tc_name f m = do
- t <- lookupType tc_name
- repMaybeT t f m
-
-repMaybeT :: Type -> (a -> MetaM (Core b))
- -> Maybe a -> MetaM (Core (Maybe b))
-repMaybeT ty _ Nothing = return $ coreNothing' ty
-repMaybeT ty f (Just es) = coreJust' ty <$> f es
-
--- | Construct Core expression for Nothing of a given type name
-coreNothing :: Name -- ^ Name of the TyCon of the element type
- -> MetaM (Core (Maybe a))
-coreNothing tc_name =
- do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
-
-coreNothingM :: Name -> MetaM (Core (Maybe a))
-coreNothingM tc_name =
- do { elt_ty <- wrapName tc_name; return (coreNothing' elt_ty) }
-
--- | Construct Core expression for Nothing of a given type
-coreNothing' :: Type -- ^ The element type
- -> Core (Maybe a)
-coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
-
--- | Store given Core expression in a Just of a given type name
-coreJust :: Name -- ^ Name of the TyCon of the element type
- -> Core a -> MetaM (Core (Maybe a))
-coreJust tc_name es
- = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
-
-coreJustM :: Name -> Core a -> MetaM (Core (Maybe a))
-coreJustM tc_name es = do { elt_ty <- wrapName tc_name; return (coreJust' elt_ty es) }
-
--- | Store given Core expression in a Just of a given type
-coreJust' :: Type -- ^ The element type
- -> Core a -> Core (Maybe a)
-coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
-
-------------------- Maybe Lists ------------------
-
--- Lookup the name and wrap it with the m variable
-repMaybeListM :: Name -> (a -> MetaM (Core b))
- -> Maybe [a] -> MetaM (Core (Maybe [b]))
-repMaybeListM tc_name f xs = do
- elt_ty <- wrapName tc_name
- repMaybeListT elt_ty f xs
-
-
-repMaybeListT :: Type -> (a -> MetaM (Core b))
- -> Maybe [a] -> MetaM (Core (Maybe [b]))
-repMaybeListT elt_ty _ Nothing = coreNothingList elt_ty
-repMaybeListT elt_ty f (Just args)
- = do { args1 <- mapM f args
- ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
-
-coreNothingList :: Type -> MetaM (Core (Maybe [a]))
-coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty)
-
------------- Literals & Variables -------------------
-
-coreIntLit :: Int -> MetaM (Core Int)
-coreIntLit i = do dflags <- getDynFlags
- return (MkC (mkIntExprInt dflags i))
-
-coreIntegerLit :: MonadThings m => Integer -> m (Core Integer)
-coreIntegerLit i = fmap MkC (mkIntegerExpr i)
-
-coreVar :: Id -> Core TH.Name -- The Id has type Name
-coreVar id = MkC (Var id)
-
------------------ Failure -----------------------
-notHandledL :: SrcSpan -> String -> SDoc -> MetaM a
-notHandledL loc what doc
- | isGoodSrcSpan loc
- = mapReaderT (putSrcSpanDs loc) $ notHandled what doc
- | otherwise
- = notHandled what doc
-
-notHandled :: String -> SDoc -> MetaM a
-notHandled what doc = lift $ failWithDs msg
- where
- msg = hang (text what <+> text "not (yet) handled by Template Haskell")
- 2 doc
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
deleted file mode 100644
index 998d46395d..0000000000
--- a/compiler/deSugar/DsMonad.hs
+++ /dev/null
@@ -1,598 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-@DsMonad@: monadery used in desugaring
--}
-
-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
-{-# LANGUAGE ViewPatterns #-}
-
-module DsMonad (
- DsM, mapM, mapAndUnzipM,
- initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
- foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
- Applicative(..),(<$>),
-
- duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,
- newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
- newFailLocalDs, newPredVarDs,
- getSrcSpanDs, putSrcSpanDs,
- mkPrintUnqualifiedDs,
- newUnique,
- UniqSupply, newUniqueSupply,
- getGhcModeDs, dsGetFamInstEnvs,
- dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
- dsLookupDataCon, dsLookupConLike,
-
- DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
-
- -- Getting and setting pattern match oracle states
- getPmDelta, updPmDelta,
-
- -- Get COMPLETE sets of a TyCon
- dsGetCompleteMatches,
-
- -- Warnings and errors
- DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
- failWithDs, failDs, discardWarningsDs,
- askNoErrsDs,
-
- -- Data types
- DsMatchContext(..),
- EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
- CanItFail(..), orFail,
-
- -- Levity polymorphism
- dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
-
- -- Trace injection
- pprRuntimeTrace
- ) where
-
-import GhcPrelude
-
-import TcRnMonad
-import FamInstEnv
-import CoreSyn
-import MkCore ( unitExpr )
-import CoreUtils ( exprType, isExprLevPoly )
-import GHC.Hs
-import GHC.IfaceToCore
-import TcMType ( checkForLevPolyX, formatLevPolyErr )
-import PrelNames
-import RdrName
-import HscTypes
-import Bag
-import BasicTypes ( Origin )
-import DataCon
-import ConLike
-import TyCon
-import GHC.HsToCore.PmCheck.Types
-import Id
-import Module
-import Outputable
-import SrcLoc
-import Type
-import UniqSupply
-import Name
-import NameEnv
-import DynFlags
-import ErrUtils
-import FastString
-import UniqFM ( lookupWithDefaultUFM )
-import Literal ( mkLitString )
-import CostCentreState
-
-import Data.IORef
-
-{-
-************************************************************************
-* *
- Data types for the desugarer
-* *
-************************************************************************
--}
-
-data DsMatchContext
- = DsMatchContext (HsMatchContext GhcRn) SrcSpan
- deriving ()
-
-instance Outputable DsMatchContext where
- ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
-
-data EquationInfo
- = EqnInfo { eqn_pats :: [Pat GhcTc]
- -- ^ The patterns for an equation
- --
- -- NB: We have /already/ applied 'decideBangHood' to
- -- these patterns. See Note [decideBangHood] in "DsUtils"
-
- , eqn_orig :: Origin
- -- ^ Was this equation present in the user source?
- --
- -- This helps us avoid warnings on patterns that GHC elaborated.
- --
- -- For instance, the pattern @-1 :: Word@ gets desugared into
- -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
- -- literal for /both/ of these cases.
-
- , eqn_rhs :: MatchResult
- -- ^ What to do after match
- }
-
-instance Outputable EquationInfo where
- ppr (EqnInfo pats _ _) = ppr pats
-
-type DsWrapper = CoreExpr -> CoreExpr
-idDsWrapper :: DsWrapper
-idDsWrapper e = e
-
--- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
--- \fail. wrap (case vs of { pats -> rhs fail })
--- where vs are not bound by wrap
-
-
--- A MatchResult is an expression with a hole in it
-data MatchResult
- = MatchResult
- CanItFail -- Tells whether the failure expression is used
- (CoreExpr -> DsM CoreExpr)
- -- Takes a expression to plug in at the
- -- failure point(s). The expression should
- -- be duplicatable!
-
-data CanItFail = CanFail | CantFail
-
-orFail :: CanItFail -> CanItFail -> CanItFail
-orFail CantFail CantFail = CantFail
-orFail _ _ = CanFail
-
-{-
-************************************************************************
-* *
- Monad functions
-* *
-************************************************************************
--}
-
--- Compatibility functions
-fixDs :: (a -> DsM a) -> DsM a
-fixDs = fixM
-
-type DsWarning = (SrcSpan, SDoc)
- -- Not quite the same as a WarnMsg, we have an SDoc here
- -- and we'll do the print_unqual stuff later on to turn it
- -- into a Doc.
-
--- | Run a 'DsM' action inside the 'TcM' monad.
-initDsTc :: DsM a -> TcM a
-initDsTc thing_inside
- = do { tcg_env <- getGblEnv
- ; msg_var <- getErrsVar
- ; hsc_env <- getTopEnv
- ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
- ; setEnvs envs thing_inside
- }
-
--- | Run a 'DsM' action inside the 'IO' monad.
-initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
-initDs hsc_env tcg_env thing_inside
- = do { msg_var <- newIORef emptyMessages
- ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
- ; runDs hsc_env envs thing_inside
- }
-
--- | Build a set of desugarer environments derived from a 'TcGblEnv'.
-mkDsEnvsFromTcGbl :: MonadIO m
- => HscEnv -> IORef Messages -> TcGblEnv
- -> m (DsGblEnv, DsLclEnv)
-mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
- = do { cc_st_var <- liftIO $ newIORef newCostCentreState
- ; let dflags = hsc_dflags hsc_env
- this_mod = tcg_mod tcg_env
- type_env = tcg_type_env tcg_env
- rdr_env = tcg_rdr_env tcg_env
- fam_inst_env = tcg_fam_inst_env tcg_env
- complete_matches = hptCompleteSigs hsc_env
- ++ tcg_complete_matches tcg_env
- ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
- msg_var cc_st_var complete_matches
- }
-
-runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
-runDs hsc_env (ds_gbl, ds_lcl) thing_inside
- = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
- (tryM thing_inside)
- ; msgs <- readIORef (ds_msgs ds_gbl)
- ; let final_res
- | errorsFound dflags msgs = Nothing
- | Right r <- res = Just r
- | otherwise = panic "initDs"
- ; return (msgs, final_res)
- }
- where dflags = hsc_dflags hsc_env
-
--- | Run a 'DsM' action in the context of an existing 'ModGuts'
-initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
-initDsWithModGuts hsc_env guts thing_inside
- = do { cc_st_var <- newIORef newCostCentreState
- ; msg_var <- newIORef emptyMessages
- ; let dflags = hsc_dflags hsc_env
- type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
- rdr_env = mg_rdr_env guts
- fam_inst_env = mg_fam_inst_env guts
- this_mod = mg_module guts
- complete_matches = hptCompleteSigs hsc_env
- ++ mg_complete_sigs guts
-
- bindsToIds (NonRec v _) = [v]
- bindsToIds (Rec binds) = map fst binds
- ids = concatMap bindsToIds (mg_binds guts)
-
- envs = mkDsEnvs dflags this_mod rdr_env type_env
- fam_inst_env msg_var cc_st_var
- complete_matches
- ; runDs hsc_env envs thing_inside
- }
-
-initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
--- Spin up a TcM context so that we can run the constraint solver
--- Returns any error messages generated by the constraint solver
--- and (Just res) if no error happened; Nothing if an error happened
---
--- Simon says: I'm not very happy about this. We spin up a complete TcM monad
--- only to immediately refine it to a TcS monad.
--- Better perhaps to make TcS into its own monad, rather than building on TcS
--- But that may in turn interact with plugins
-
-initTcDsForSolver thing_inside
- = do { (gbl, lcl) <- getEnvs
- ; hsc_env <- getTopEnv
-
- ; let DsGblEnv { ds_mod = mod
- , ds_fam_inst_env = fam_inst_env } = gbl
-
- DsLclEnv { dsl_loc = loc } = lcl
-
- ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
- updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
- thing_inside }
-
-mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
- -> IORef Messages -> IORef CostCentreState -> [CompleteMatch]
- -> (DsGblEnv, DsLclEnv)
-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var
- complete_matches
- = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs",
- if_rec_types = Just (mod, return type_env) }
- if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
- False -- not boot!
- real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
- completeMatchMap = mkCompleteMatchMap complete_matches
- gbl_env = DsGblEnv { ds_mod = mod
- , ds_fam_inst_env = fam_inst_env
- , ds_if_env = (if_genv, if_lenv)
- , ds_unqual = mkPrintUnqualified dflags rdr_env
- , ds_msgs = msg_var
- , ds_complete_matches = completeMatchMap
- , ds_cc_st = cc_st_var
- }
- lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
- , dsl_loc = real_span
- , dsl_delta = initDelta
- }
- in (gbl_env, lcl_env)
-
-
-{-
-************************************************************************
-* *
- Operations in the monad
-* *
-************************************************************************
-
-And all this mysterious stuff is so we can occasionally reach out and
-grab one or more names. @newLocalDs@ isn't exported---exported
-functions are defined with it. The difference in name-strings makes
-it easier to read debugging output.
-
-Note [Levity polymorphism checking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-According to the "Levity Polymorphism" paper (PLDI '17), levity
-polymorphism is forbidden in precisely two places: in the type of a bound
-term-level argument and in the type of an argument to a function. The paper
-explains it more fully, but briefly: expressions in these contexts need to be
-stored in registers, and it's hard (read, impossible) to store something
-that's levity polymorphic.
-
-We cannot check for bad levity polymorphism conveniently in the type checker,
-because we can't tell, a priori, which levity metavariables will be solved.
-At one point, I (Richard) thought we could check in the zonker, but it's hard
-to know where precisely are the abstracted variables and the arguments. So
-we check in the desugarer, the only place where we can see the Core code and
-still report respectable syntax to the user. This covers the vast majority
-of cases; see calls to DsMonad.dsNoLevPoly and friends.
-
-Levity polymorphism is also prohibited in the types of binders, and the
-desugarer checks for this in GHC-generated Ids. (The zonker handles
-the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
-The newSysLocalDs variant is used in the vast majority of cases where
-the binder is obviously not levity polymorphic, omitting the check.
-It would be nice to ASSERT that there is no levity polymorphism here,
-but we can't, because of the fixM in DsArrows. It's all OK, though:
-Core Lint will catch an error here.
-
-However, the desugarer is the wrong place for certain checks. In particular,
-the desugarer can't report a sensible error message if an HsWrapper is malformed.
-After all, GHC itself produced the HsWrapper. So we store some message text
-in the appropriate HsWrappers (e.g. WpFun) that we can print out in the
-desugarer.
-
-There are a few more checks in places where Core is generated outside the
-desugarer. For example, in datatype and class declarations, where levity
-polymorphism is checked for during validity checking. It would be nice to
-have one central place for all this, but that doesn't seem possible while
-still reporting nice error messages.
-
--}
-
--- Make a new Id with the same print name, but different type, and new unique
-newUniqueId :: Id -> Type -> DsM Id
-newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))
-
-duplicateLocalDs :: Id -> DsM Id
-duplicateLocalDs old_local
- = do { uniq <- newUnique
- ; return (setIdUnique old_local uniq) }
-
-newPredVarDs :: PredType -> DsM Var
-newPredVarDs
- = mkSysLocalOrCoVarM (fsLit "ds") -- like newSysLocalDs, but we allow covars
-
-newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
-newSysLocalDsNoLP = mk_local (fsLit "ds")
-
--- this variant should be used when the caller can be sure that the variable type
--- is not levity-polymorphic. It is necessary when the type is knot-tied because
--- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
-newSysLocalDs = mkSysLocalM (fsLit "ds")
-newFailLocalDs = mkSysLocalM (fsLit "fail")
- -- the fail variable is used only in a situation where we can tell that
- -- levity-polymorphism is impossible.
-
-newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
-newSysLocalsDsNoLP = mapM newSysLocalDsNoLP
-newSysLocalsDs = mapM newSysLocalDs
-
-mk_local :: FastString -> Type -> DsM Id
-mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>
- ppr ty) -- could improve the msg with another
- -- parameter indicating context
- ; mkSysLocalOrCoVarM fs ty }
-
-{-
-We can also reach out and either set/grab location information from
-the @SrcSpan@ being carried around.
--}
-
-getGhcModeDs :: DsM GhcMode
-getGhcModeDs = getDynFlags >>= return . ghcMode
-
--- | Get the current pattern match oracle state. See 'dsl_delta'.
-getPmDelta :: DsM Delta
-getPmDelta = do { env <- getLclEnv; return (dsl_delta env) }
-
--- | Set the pattern match oracle state within the scope of the given action.
--- See 'dsl_delta'.
-updPmDelta :: Delta -> DsM a -> DsM a
-updPmDelta delta = updLclEnv (\env -> env { dsl_delta = delta })
-
-getSrcSpanDs :: DsM SrcSpan
-getSrcSpanDs = do { env <- getLclEnv
- ; return (RealSrcSpan (dsl_loc env)) }
-
-putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
-putSrcSpanDs (UnhelpfulSpan {}) thing_inside
- = thing_inside
-putSrcSpanDs (RealSrcSpan real_span) thing_inside
- = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
-
--- | Emit a warning for the current source location
--- NB: Warns whether or not -Wxyz is set
-warnDs :: WarnReason -> SDoc -> DsM ()
-warnDs reason warn
- = do { env <- getGblEnv
- ; loc <- getSrcSpanDs
- ; dflags <- getDynFlags
- ; let msg = makeIntoWarning reason $
- mkWarnMsg dflags loc (ds_unqual env) warn
- ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
-
--- | Emit a warning only if the correct WarnReason is set in the DynFlags
-warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
-warnIfSetDs flag warn
- = whenWOptM flag $
- warnDs (Reason flag) warn
-
-errDs :: SDoc -> DsM ()
-errDs err
- = do { env <- getGblEnv
- ; loc <- getSrcSpanDs
- ; dflags <- getDynFlags
- ; let msg = mkErrMsg dflags loc (ds_unqual env) err
- ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
-
--- | Issue an error, but return the expression for (), so that we can continue
--- reporting errors.
-errDsCoreExpr :: SDoc -> DsM CoreExpr
-errDsCoreExpr err
- = do { errDs err
- ; return unitExpr }
-
-failWithDs :: SDoc -> DsM a
-failWithDs err
- = do { errDs err
- ; failM }
-
-failDs :: DsM a
-failDs = failM
-
--- (askNoErrsDs m) runs m
--- If m fails,
--- then (askNoErrsDs m) fails
--- If m succeeds with result r,
--- then (askNoErrsDs m) succeeds with result (r, b),
--- where b is True iff m generated no errors
--- Regardless of success or failure,
--- propagate any errors/warnings generated by m
---
--- c.f. TcRnMonad.askNoErrs
-askNoErrsDs :: DsM a -> DsM (a, Bool)
-askNoErrsDs thing_inside
- = do { errs_var <- newMutVar emptyMessages
- ; env <- getGblEnv
- ; mb_res <- tryM $ -- Be careful to catch exceptions
- -- so that we propagate errors correctly
- -- (#13642)
- setGblEnv (env { ds_msgs = errs_var }) $
- thing_inside
-
- -- Propagate errors
- ; msgs@(warns, errs) <- readMutVar errs_var
- ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
-
- -- And return
- ; case mb_res of
- Left _ -> failM
- Right res -> do { dflags <- getDynFlags
- ; let errs_found = errorsFound dflags msgs
- ; return (res, not errs_found) } }
-
-mkPrintUnqualifiedDs :: DsM PrintUnqualified
-mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
-
-instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
- lookupThing = dsLookupGlobal
-
-dsLookupGlobal :: Name -> DsM TyThing
--- Very like TcEnv.tcLookupGlobal
-dsLookupGlobal name
- = do { env <- getGblEnv
- ; setEnvs (ds_if_env env)
- (tcIfaceGlobal name) }
-
-dsLookupGlobalId :: Name -> DsM Id
-dsLookupGlobalId name
- = tyThingId <$> dsLookupGlobal name
-
-dsLookupTyCon :: Name -> DsM TyCon
-dsLookupTyCon name
- = tyThingTyCon <$> dsLookupGlobal name
-
-dsLookupDataCon :: Name -> DsM DataCon
-dsLookupDataCon name
- = tyThingDataCon <$> dsLookupGlobal name
-
-dsLookupConLike :: Name -> DsM ConLike
-dsLookupConLike name
- = tyThingConLike <$> dsLookupGlobal name
-
-
-dsGetFamInstEnvs :: DsM FamInstEnvs
--- Gets both the external-package inst-env
--- and the home-pkg inst env (includes module being compiled)
-dsGetFamInstEnvs
- = do { eps <- getEps; env <- getGblEnv
- ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
-
-dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
-dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
-
--- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`.
-dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
-dsGetCompleteMatches tc = do
- eps <- getEps
- env <- getGblEnv
- let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
- eps_matches_list = lookup_completes $ eps_complete_matches eps
- env_matches_list = lookup_completes $ ds_complete_matches env
- return $ eps_matches_list ++ env_matches_list
-
-dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
-dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
-
-dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
-dsExtendMetaEnv menv thing_inside
- = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
-
-discardWarningsDs :: DsM a -> DsM a
--- Ignore warnings inside the thing inside;
--- used to ignore inaccessible cases etc. inside generated code
-discardWarningsDs thing_inside
- = do { env <- getGblEnv
- ; old_msgs <- readTcRef (ds_msgs env)
-
- ; result <- thing_inside
-
- -- Revert messages to old_msgs
- ; writeTcRef (ds_msgs env) old_msgs
-
- ; return result }
-
--- | Fail with an error message if the type is levity polymorphic.
-dsNoLevPoly :: Type -> SDoc -> DsM ()
--- See Note [Levity polymorphism checking]
-dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty
-
--- | Check an expression for levity polymorphism, failing if it is
--- levity polymorphic.
-dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
--- See Note [Levity polymorphism checking]
-dsNoLevPolyExpr e doc
- | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
- | otherwise = return ()
-
--- | Runs the thing_inside. If there are no errors, then returns the expr
--- given. Otherwise, returns unitExpr. This is useful for doing a bunch
--- of levity polymorphism checks and then avoiding making a core App.
--- (If we make a core App on a levity polymorphic argument, detecting how
--- to handle the let/app invariant might call isUnliftedType, which panics
--- on a levity polymorphic type.)
--- See #12709 for an example of why this machinery is necessary.
-dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
-dsWhenNoErrs thing_inside mk_expr
- = do { (result, no_errs) <- askNoErrsDs thing_inside
- ; return $ if no_errs
- then mk_expr result
- else unitExpr }
-
--- | Inject a trace message into the compiled program. Whereas
--- pprTrace prints out information *while compiling*, pprRuntimeTrace
--- captures that information and causes it to be printed *at runtime*
--- using Debug.Trace.trace.
---
--- pprRuntimeTrace hdr doc expr
---
--- will produce an expression that looks like
---
--- trace (hdr + doc) expr
---
--- When using this to debug a module that Debug.Trace depends on,
--- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
--- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
--- but that doesn't seem worth the effort and maintenance cost.
-pprRuntimeTrace :: String -- ^ header
- -> SDoc -- ^ information to output
- -> CoreExpr -- ^ expression
- -> DsM CoreExpr
-pprRuntimeTrace str doc expr = do
- traceId <- dsLookupGlobalId traceName
- unpackCStringId <- dsLookupGlobalId unpackCStringName
- dflags <- getDynFlags
- let message :: CoreExpr
- message = App (Var unpackCStringId) $
- Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)
- return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs
deleted file mode 100644
index 8d3517410e..0000000000
--- a/compiler/deSugar/DsUsage.hs
+++ /dev/null
@@ -1,375 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module DsUsage (
- -- * Dependency/fingerprinting code (used by GHC.Iface.Utils)
- mkUsageInfo, mkUsedNames, mkDependencies
- ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import DynFlags
-import HscTypes
-import TcRnTypes
-import Name
-import NameSet
-import Module
-import Outputable
-import Util
-import UniqSet
-import UniqFM
-import Fingerprint
-import Maybes
-import Packages
-import Finder
-
-import Control.Monad (filterM)
-import Data.List
-import Data.IORef
-import Data.Map (Map)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import System.Directory
-import System.FilePath
-
-{- Note [Module self-dependency]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-GHC.Rename.Names.calculateAvails asserts the invariant that a module must not occur in
-its own dep_orphs or dep_finsts. However, if we aren't careful this can occur
-in the presence of hs-boot files: Consider that we have two modules, A and B,
-both with hs-boot files,
-
- A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A
- A.hs-boot declares an orphan instance A.hs defines the orphan instance
-
-In this case, B's dep_orphs will contain A due to its SOURCE import of A.
-Consequently, A will contain itself in its imp_orphs due to its import of B.
-This fact would end up being recorded in A's interface file. This would then
-break the invariant asserted by calculateAvails that a module does not itself in
-its dep_orphs. This was the cause of #14128.
-
--}
-
--- | Extract information from the rename and typecheck phases to produce
--- a dependencies information for the module being compiled.
---
--- The first argument is additional dependencies from plugins
-mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies
-mkDependencies iuid pluginModules
- (TcGblEnv{ tcg_mod = mod,
- tcg_imports = imports,
- tcg_th_used = th_var
- })
- = do
- -- Template Haskell used?
- let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ]
- plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms)
- th_used <- readIORef th_var
- let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports)
- (moduleName mod))
- -- M.hi-boot can be in the imp_dep_mods, but we must remove
- -- it before recording the modules on which this one depends!
- -- (We want to retain M.hi-boot in imp_dep_mods so that
- -- loadHiBootInterface can see if M's direct imports depend
- -- on M.hi-boot, and hence that we should do the hi-boot consistency
- -- check.)
-
- dep_orphs = filter (/= mod) (imp_orphs imports)
- -- We must also remove self-references from imp_orphs. See
- -- Note [Module self-dependency]
-
- raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs
-
- pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) raw_pkgs
- | otherwise = raw_pkgs
-
- -- Set the packages required to be Safe according to Safe Haskell.
- -- See Note [Tracking Trust Transitively] in GHC.Rename.Names
- sorted_pkgs = sort (Set.toList pkgs)
- trust_pkgs = imp_trust_pkgs imports
- dep_pkgs' = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs
-
- return Deps { dep_mods = dep_mods,
- dep_pkgs = dep_pkgs',
- dep_orphs = dep_orphs,
- dep_plgins = dep_plgins,
- dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
- -- sort to get into canonical order
- -- NB. remember to use lexicographic ordering
-
-mkUsedNames :: TcGblEnv -> NameSet
-mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
-
-mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath]
- -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage]
-mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged
- pluginModules
- = do
- eps <- hscEPS hsc_env
- hashes <- mapM getFileHash dependent_files
- plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules
- let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
- dir_imp_mods used_names
- usages = mod_usages ++ [ UsageFile { usg_file_path = f
- , usg_file_hash = hash }
- | (f, hash) <- zip dependent_files hashes ]
- ++ [ UsageMergedRequirement
- { usg_mod = mod,
- usg_mod_hash = hash
- }
- | (mod, hash) <- merged ]
- ++ concat plugin_usages
- usages `seqList` return usages
- -- seq the list of Usages returned: occasionally these
- -- don't get evaluated for a while and we can end up hanging on to
- -- the entire collection of Ifaces.
-
-{- Note [Plugin dependencies]
-Modules for which plugins were used in the compilation process, should be
-recompiled whenever one of those plugins changes. But how do we know if a
-plugin changed from the previous time a module was compiled?
-
-We could try storing the fingerprints of the interface files of plugins in
-the interface file of the module. And see if there are changes between
-compilation runs. However, this is pretty much a non-option because interface
-fingerprints of plugin modules are fairly stable, unless you compile plugins
-with optimisations turned on, and give basically all binders an INLINE pragma.
-
-So instead:
-
- * For plugins that were built locally: we store the filepath and hash of the
- object files of the module with the `plugin` binder, and the object files of
- modules that are dependencies of the plugin module and belong to the same
- `UnitId` as the plugin
- * For plugins in an external package: we store the filepath and hash of
- the dynamic library containing the plugin module.
-
-During recompilation we then compare the hashes of those files again to see
-if anything has changed.
-
-One issue with this approach is that object files are currently (GHC 8.6.1)
-not created fully deterministicly, which could sometimes induce accidental
-recompilation of a module for which plugins were used in the compile process.
-
-One way to improve this is to either:
-
- * Have deterministic object file creation
- * Create and store implementation hashes, which would be based on the Core
- of the module and the implementation hashes of its dependencies, and then
- compare implementation hashes for recompilation. Creation of implementation
- hashes is however potentially expensive.
--}
-mkPluginUsage :: HscEnv -> ModIface -> IO [Usage]
-mkPluginUsage hsc_env pluginModule
- = case lookupPluginModuleWithSuggestions dflags pNm Nothing of
- LookupFound _ pkg -> do
- -- The plugin is from an external package:
- -- search for the library files containing the plugin.
- let searchPaths = collectLibraryPaths dflags [pkg]
- useDyn = WayDyn `elem` ways dflags
- suffix = if useDyn then soExt platform else "a"
- libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix
- | searchPath <- searchPaths
- , libLoc <- packageHsLibs dflags pkg
- ]
- -- we also try to find plugin library files by adding WayDyn way,
- -- if it isn't already present (see trac #15492)
- paths =
- if useDyn
- then libLocs
- else
- let dflags' = updateWays (addWay' WayDyn dflags)
- dlibLocs = [ searchPath </> mkHsSOName platform dlibLoc
- | searchPath <- searchPaths
- , dlibLoc <- packageHsLibs dflags' pkg
- ]
- in libLocs ++ dlibLocs
- files <- filterM doesFileExist paths
- case files of
- [] ->
- pprPanic
- ( "mkPluginUsage: missing plugin library, tried:\n"
- ++ unlines paths
- )
- (ppr pNm)
- _ -> mapM hashFile (nub files)
- _ -> do
- foundM <- findPluginModule hsc_env pNm
- case foundM of
- -- The plugin was built locally: look up the object file containing
- -- the `plugin` binder, and all object files belong to modules that are
- -- transitive dependencies of the plugin that belong to the same package.
- Found ml _ -> do
- pluginObject <- hashFile (ml_obj_file ml)
- depObjects <- catMaybes <$> mapM lookupObjectFile deps
- return (nub (pluginObject : depObjects))
- _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm)
- where
- dflags = hsc_dflags hsc_env
- platform = targetPlatform dflags
- pNm = moduleName (mi_module pluginModule)
- pPkg = moduleUnitId (mi_module pluginModule)
- deps = map fst (dep_mods (mi_deps pluginModule))
-
- -- Lookup object file for a plugin dependency,
- -- from the same package as the plugin.
- lookupObjectFile nm = do
- foundM <- findImportedModule hsc_env nm Nothing
- case foundM of
- Found ml m
- | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml)
- | otherwise -> return Nothing
- _ -> pprPanic "mkPluginUsage: no object for dependency"
- (ppr pNm <+> ppr nm)
-
- hashFile f = do
- fExist <- doesFileExist f
- if fExist
- then do
- h <- getFileHash f
- return (UsageFile f h)
- else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f)
-
-mk_mod_usage_info :: PackageIfaceTable
- -> HscEnv
- -> Module
- -> ImportedMods
- -> NameSet
- -> [Usage]
-mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
- = mapMaybe mkUsage usage_mods
- where
- hpt = hsc_HPT hsc_env
- dflags = hsc_dflags hsc_env
- this_pkg = thisPackage dflags
-
- used_mods = moduleEnvKeys ent_map
- dir_imp_mods = moduleEnvKeys direct_imports
- all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
- usage_mods = sortBy stableModuleCmp all_mods
- -- canonical order is imported, to avoid interface-file
- -- wobblage.
-
- -- ent_map groups together all the things imported and used
- -- from a particular module
- ent_map :: ModuleEnv [OccName]
- ent_map = nonDetFoldUniqSet add_mv emptyModuleEnv used_names
- -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName
- -- in ent_hashs
- where
- add_mv name mv_map
- | isWiredInName name = mv_map -- ignore wired-in names
- | otherwise
- = case nameModule_maybe name of
- Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map
- -- See Note [Internal used_names]
-
- Just mod ->
- -- See Note [Identity versus semantic module]
- let mod' = if isHoleModule mod
- then mkModule this_pkg (moduleName mod)
- else mod
- -- This lambda function is really just a
- -- specialised (++); originally came about to
- -- avoid quadratic behaviour (trac #2680)
- in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ]
- where occ = nameOccName name
-
- -- We want to create a Usage for a home module if
- -- a) we used something from it; has something in used_names
- -- b) we imported it, even if we used nothing from it
- -- (need to recompile if its export list changes: export_fprint)
- mkUsage :: Module -> Maybe Usage
- mkUsage mod
- | isNothing maybe_iface -- We can't depend on it if we didn't
- -- load its interface.
- || mod == this_mod -- We don't care about usages of
- -- things in *this* module
- = Nothing
-
- | moduleUnitId mod /= this_pkg
- = Just UsagePackageModule{ usg_mod = mod,
- usg_mod_hash = mod_hash,
- usg_safe = imp_safe }
- -- for package modules, we record the module hash only
-
- | (null used_occs
- && isNothing export_hash
- && not is_direct_import
- && not finsts_mod)
- = Nothing -- Record no usage info
- -- for directly-imported modules, we always want to record a usage
- -- on the orphan hash. This is what triggers a recompilation if
- -- an orphan is added or removed somewhere below us in the future.
-
- | otherwise
- = Just UsageHomeModule {
- usg_mod_name = moduleName mod,
- usg_mod_hash = mod_hash,
- usg_exports = export_hash,
- usg_entities = Map.toList ent_hashs,
- usg_safe = imp_safe }
- where
- maybe_iface = lookupIfaceByModule hpt pit mod
- -- In one-shot mode, the interfaces for home-package
- -- modules accumulate in the PIT not HPT. Sigh.
-
- Just iface = maybe_iface
- finsts_mod = mi_finsts (mi_final_exts iface)
- hash_env = mi_hash_fn (mi_final_exts iface)
- mod_hash = mi_mod_hash (mi_final_exts iface)
- export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface))
- | otherwise = Nothing
-
- by_is_safe (ImportedByUser imv) = imv_is_safe imv
- by_is_safe _ = False
- (is_direct_import, imp_safe)
- = case lookupModuleEnv direct_imports mod of
- -- ezyang: I'm not sure if any is the correct
- -- metric here. If safety was guaranteed to be uniform
- -- across all imports, why did the old code only look
- -- at the first import?
- Just bys -> (True, any by_is_safe bys)
- Nothing -> (False, safeImplicitImpsReq dflags)
- -- Nothing case is for references to entities which were
- -- not directly imported (NB: the "implicit" Prelude import
- -- counts as directly imported! An entity is not directly
- -- imported if, e.g., we got a reference to it from a
- -- reexport of another module.)
-
- used_occs = lookupModuleEnv ent_map mod `orElse` []
-
- -- Making a Map here ensures that (a) we remove duplicates
- -- when we have usages on several subordinates of a single parent,
- -- and (b) that the usages emerge in a canonical order, which
- -- is why we use Map rather than OccEnv: Map works
- -- using Ord on the OccNames, which is a lexicographic ordering.
- ent_hashs :: Map OccName Fingerprint
- ent_hashs = Map.fromList (map lookup_occ used_occs)
-
- lookup_occ occ =
- case hash_env occ of
- Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
- Just r -> r
-
- depend_on_exports = is_direct_import
- {- True
- Even if we used 'import M ()', we have to register a
- usage on the export list because we are sensitive to
- changes in orphan instances/rules.
- False
- In GHC 6.8.x we always returned true, and in
- fact it recorded a dependency on *all* the
- modules underneath in the dependency tree. This
- happens to make orphans work right, but is too
- expensive: it'll read too many interface files.
- The 'isNothing maybe_iface' check above saved us
- from generating many of these usages (at least in
- one-shot mode), but that's even more bogus!
- -}
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
deleted file mode 100644
index 9d6b709dc9..0000000000
--- a/compiler/deSugar/DsUtils.hs
+++ /dev/null
@@ -1,1001 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Utilities for desugaring
-
-This module exports some utility functions of no great interest.
--}
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
--- | Utility functions for constructing Core syntax, principally for desugaring
-module DsUtils (
- EquationInfo(..),
- firstPat, shiftEqns,
-
- MatchResult(..), CanItFail(..), CaseAlt(..),
- cantFailMatchResult, alwaysFailMatchResult,
- extractMatchResult, combineMatchResults,
- adjustMatchResult, adjustMatchResultDs,
- mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
- matchCanFail, mkEvalMatchResult,
- mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
- wrapBind, wrapBinds,
-
- mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
-
- seqVar,
-
- -- LHs tuples
- mkLHsPatTup, mkVanillaTuplePat,
- mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
-
- mkSelectorBinds,
-
- selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
- mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,
- isTrueLHsExpr
- ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import {-# SOURCE #-} Match ( matchSimply )
-import {-# SOURCE #-} DsExpr ( dsLExpr )
-
-import GHC.Hs
-import TcHsSyn
-import TcType( tcSplitTyConApp )
-import CoreSyn
-import DsMonad
-
-import CoreUtils
-import MkCore
-import MkId
-import Id
-import Literal
-import TyCon
-import DataCon
-import PatSyn
-import Type
-import Coercion
-import TysPrim
-import TysWiredIn
-import BasicTypes
-import ConLike
-import UniqSet
-import UniqSupply
-import Module
-import PrelNames
-import Name( isInternalName )
-import Outputable
-import SrcLoc
-import Util
-import DynFlags
-import FastString
-import qualified GHC.LanguageExtensions as LangExt
-
-import TcEvidence
-
-import Control.Monad ( zipWithM )
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NEL
-
-{-
-************************************************************************
-* *
-\subsection{ Selecting match variables}
-* *
-************************************************************************
-
-We're about to match against some patterns. We want to make some
-@Ids@ to use as match variables. If a pattern has an @Id@ readily at
-hand, which should indeed be bound to the pattern as a whole, then use it;
-otherwise, make one up.
--}
-
-selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
--- Postcondition: the returned Id has an Internal Name
-selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
-
--- (selectMatchVars ps tys) chooses variables of type tys
--- to use for matching ps against. If the pattern is a variable,
--- we try to use that, to save inventing lots of fresh variables.
---
--- OLD, but interesting note:
--- But even if it is a variable, its type might not match. Consider
--- data T a where
--- T1 :: Int -> T Int
--- T2 :: a -> T a
---
--- f :: T a -> a -> Int
--- f (T1 i) (x::Int) = x
--- f (T2 i) (y::a) = 0
--- Then we must not choose (x::Int) as the matching variable!
--- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
-
-selectMatchVars :: [Pat GhcTc] -> DsM [Id]
--- Postcondition: the returned Ids have Internal Names
-selectMatchVars ps = mapM selectMatchVar ps
-
-selectMatchVar :: Pat GhcTc -> DsM Id
--- Postcondition: the returned Id has an Internal Name
-selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)
-selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)
-selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat)
-selectMatchVar (VarPat _ var) = return (localiseId (unLoc var))
- -- Note [Localise pattern binders]
-selectMatchVar (AsPat _ var _) = return (unLoc var)
-selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat)
- -- OK, better make up one...
-
-{- Note [Localise pattern binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider module M where
- [Just a] = e
-After renaming it looks like
- module M where
- [Just M.a] = e
-
-We don't generalise, since it's a pattern binding, monomorphic, etc,
-so after desugaring we may get something like
- M.a = case e of (v:_) ->
- case v of Just M.a -> M.a
-Notice the "M.a" in the pattern; after all, it was in the original
-pattern. However, after optimisation those pattern binders can become
-let-binders, and then end up floated to top level. They have a
-different *unique* by then (the simplifier is good about maintaining
-proper scoping), but it's BAD to have two top-level bindings with the
-External Name M.a, because that turns into two linker symbols for M.a.
-It's quite rare for this to actually *happen* -- the only case I know
-of is tc003 compiled with the 'hpc' way -- but that only makes it
-all the more annoying.
-
-To avoid this, we craftily call 'localiseId' in the desugarer, which
-simply turns the External Name for the Id into an Internal one, but
-doesn't change the unique. So the desugarer produces this:
- M.a{r8} = case e of (v:_) ->
- case v of Just a{r8} -> M.a{r8}
-The unique is still 'r8', but the binding site in the pattern
-is now an Internal Name. Now the simplifier's usual mechanisms
-will propagate that Name to all the occurrence sites, as well as
-un-shadowing it, so we'll get
- M.a{r8} = case e of (v:_) ->
- case v of Just a{s77} -> a{s77}
-In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
-runs on the output of the desugarer, so all is well by the end of
-the desugaring pass.
-
-See also Note [MatchIds] in Match.hs
-
-************************************************************************
-* *
-* type synonym EquationInfo and access functions for its pieces *
-* *
-************************************************************************
-\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
-
-The ``equation info'' used by @match@ is relatively complicated and
-worthy of a type synonym and a few handy functions.
--}
-
-firstPat :: EquationInfo -> Pat GhcTc
-firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
-
-shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
--- Drop the first pattern in each equation
-shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }
-
--- Functions on MatchResults
-
-matchCanFail :: MatchResult -> Bool
-matchCanFail (MatchResult CanFail _) = True
-matchCanFail (MatchResult CantFail _) = False
-
-alwaysFailMatchResult :: MatchResult
-alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
-
-cantFailMatchResult :: CoreExpr -> MatchResult
-cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
-
-extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
-extractMatchResult (MatchResult CantFail match_fn) _
- = match_fn (error "It can't fail!")
-
-extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
- (fail_bind, if_it_fails) <- mkFailurePair fail_expr
- body <- match_fn if_it_fails
- return (mkCoreLet fail_bind body)
-
-
-combineMatchResults :: MatchResult -> MatchResult -> MatchResult
-combineMatchResults (MatchResult CanFail body_fn1)
- (MatchResult can_it_fail2 body_fn2)
- = MatchResult can_it_fail2 body_fn
- where
- body_fn fail = do body2 <- body_fn2 fail
- (fail_bind, duplicatable_expr) <- mkFailurePair body2
- body1 <- body_fn1 duplicatable_expr
- return (Let fail_bind body1)
-
-combineMatchResults match_result1@(MatchResult CantFail _) _
- = match_result1
-
-adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
-adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
- = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
-
-adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
-adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
- = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
-
-wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
-wrapBinds [] e = e
-wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
-
-wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
-wrapBind new old body -- NB: this function must deal with term
- | new==old = body -- variables, type variables or coercion variables
- | otherwise = Let (NonRec new (varToCoreExpr old)) body
-
-seqVar :: Var -> CoreExpr -> CoreExpr
-seqVar var body = mkDefaultCase (Var var) var body
-
-mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
-mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
-
--- (mkViewMatchResult var' viewExpr mr) makes the expression
--- let var' = viewExpr in mr
-mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
-mkViewMatchResult var' viewExpr =
- adjustMatchResult (mkCoreLet (NonRec var' viewExpr))
-
-mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
-mkEvalMatchResult var ty
- = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
-
-mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
-mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
- = MatchResult CanFail (\fail -> do body <- body_fn fail
- return (mkIfThenElse pred_expr body fail))
-
-mkCoPrimCaseMatchResult :: Id -- Scrutinee
- -> Type -- Type of the case
- -> [(Literal, MatchResult)] -- Alternatives
- -> MatchResult -- Literals are all unlifted
-mkCoPrimCaseMatchResult var ty match_alts
- = MatchResult CanFail mk_case
- where
- mk_case fail = do
- alts <- mapM (mk_alt fail) sorted_alts
- return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
-
- sorted_alts = sortWith fst match_alts -- Right order for a Case
- mk_alt fail (lit, MatchResult _ body_fn)
- = ASSERT( not (litIsLifted lit) )
- do body <- body_fn fail
- return (LitAlt lit, [], body)
-
-data CaseAlt a = MkCaseAlt{ alt_pat :: a,
- alt_bndrs :: [Var],
- alt_wrapper :: HsWrapper,
- alt_result :: MatchResult }
-
-mkCoAlgCaseMatchResult
- :: Id -- ^ Scrutinee
- -> Type -- ^ Type of exp
- -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts)
- -> MatchResult
-mkCoAlgCaseMatchResult var ty match_alts
- | isNewtype -- Newtype case; use a let
- = ASSERT( null match_alts_tail && null (tail arg_ids1) )
- mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
-
- | otherwise
- = mkDataConCase var ty match_alts
- where
- isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))
-
- -- [Interesting: because of GADTs, we can't rely on the type of
- -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
-
- alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail
- = match_alts
- -- Stuff for newtype
- arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
- var_ty = idType var
- (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
- -- (not that splitTyConApp does, these days)
- newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
-
-mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
-mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
-
-mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
-mkPatSynCase var ty alt fail = do
- matcher <- dsLExpr $ mkLHsWrap wrapper $
- nlHsTyApp matcher [getRuntimeRep ty, ty]
- let MatchResult _ mkCont = match_result
- cont <- mkCoreLams bndrs <$> mkCont fail
- return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
- where
- MkCaseAlt{ alt_pat = psyn,
- alt_bndrs = bndrs,
- alt_wrapper = wrapper,
- alt_result = match_result} = alt
- (matcher, needs_void_lam) = patSynMatcher psyn
-
- -- See Note [Matchers and builders for pattern synonyms] in PatSyns
- -- on these extra Void# arguments
- ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
- | otherwise = cont
-
-mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult
-mkDataConCase var ty alts@(alt1 :| _) = MatchResult fail_flag mk_case
- where
- con1 = alt_pat alt1
- tycon = dataConTyCon con1
- data_cons = tyConDataCons tycon
- match_results = fmap alt_result alts
-
- sorted_alts :: NonEmpty (CaseAlt DataCon)
- sorted_alts = NEL.sortWith (dataConTag . alt_pat) alts
-
- var_ty = idType var
- (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
- -- (not that splitTyConApp does, these days)
-
- mk_case :: CoreExpr -> DsM CoreExpr
- mk_case fail = do
- alts <- mapM (mk_alt fail) sorted_alts
- return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ NEL.toList alts)
-
- mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
- mk_alt fail MkCaseAlt{ alt_pat = con,
- alt_bndrs = args,
- alt_result = MatchResult _ body_fn }
- = do { body <- body_fn fail
- ; case dataConBoxer con of {
- Nothing -> return (DataAlt con, args, body) ;
- Just (DCB boxer) ->
- do { us <- newUniqueSupply
- ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
- ; return (DataAlt con, rep_ids, mkLets binds body) } } }
-
- mk_default :: CoreExpr -> [CoreAlt]
- mk_default fail | exhaustive_case = []
- | otherwise = [(DEFAULT, [], fail)]
-
- fail_flag :: CanItFail
- fail_flag | exhaustive_case
- = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- NEL.toList match_results]
- | otherwise
- = CanFail
-
- mentioned_constructors = mkUniqSet $ map alt_pat $ NEL.toList alts
- un_mentioned_constructors
- = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
- exhaustive_case = isEmptyUniqSet un_mentioned_constructors
-
-{-
-************************************************************************
-* *
-\subsection{Desugarer's versions of some Core functions}
-* *
-************************************************************************
--}
-
-mkErrorAppDs :: Id -- The error function
- -> Type -- Type to which it should be applied
- -> SDoc -- The error message string to pass
- -> DsM CoreExpr
-
-mkErrorAppDs err_id ty msg = do
- src_loc <- getSrcSpanDs
- dflags <- getDynFlags
- let
- full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
- core_msg = Lit (mkLitString full_msg)
- -- mkLitString returns a result of type String#
- return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])
-
-{-
-'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'.
-
-Note [Desugaring seq]
-~~~~~~~~~~~~~~~~~~~~~
-
-There are a few subtleties in the desugaring of `seq`:
-
- 1. (as described in #1031)
-
- Consider,
- f x y = x `seq` (y `seq` (# x,y #))
-
- The [CoreSyn let/app invariant] means that, other things being equal, because
- the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
-
- f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
-
- But that is bad for two reasons:
- (a) we now evaluate y before x, and
- (b) we can't bind v to an unboxed pair
-
- Seq is very, very special! So we recognise it right here, and desugar to
- case x of _ -> case y of _ -> (# x,y #)
-
- 2. (as described in #2273)
-
- Consider
- let chp = case b of { True -> fst x; False -> 0 }
- in chp `seq` ...chp...
- Here the seq is designed to plug the space leak of retaining (snd x)
- for too long.
-
- If we rely on the ordinary inlining of seq, we'll get
- let chp = case b of { True -> fst x; False -> 0 }
- case chp of _ { I# -> ...chp... }
-
- But since chp is cheap, and the case is an alluring contet, we'll
- inline chp into the case scrutinee. Now there is only one use of chp,
- so we'll inline a second copy. Alas, we've now ruined the purpose of
- the seq, by re-introducing the space leak:
- case (case b of {True -> fst x; False -> 0}) of
- I# _ -> ...case b of {True -> fst x; False -> 0}...
-
- We can try to avoid doing this by ensuring that the binder-swap in the
- case happens, so we get his at an early stage:
- case chp of chp2 { I# -> ...chp2... }
- But this is fragile. The real culprit is the source program. Perhaps we
- should have said explicitly
- let !chp2 = chp in ...chp2...
-
- But that's painful. So the code here does a little hack to make seq
- more robust: a saturated application of 'seq' is turned *directly* into
- the case expression, thus:
- x `seq` e2 ==> case x of x -> e2 -- Note shadowing!
- e1 `seq` e2 ==> case x of _ -> e2
-
- So we desugar our example to:
- let chp = case b of { True -> fst x; False -> 0 }
- case chp of chp { I# -> ...chp... }
- And now all is well.
-
- The reason it's a hack is because if you define mySeq=seq, the hack
- won't work on mySeq.
-
- 3. (as described in #2409)
-
- The isLocalId ensures that we don't turn
- True `seq` e
- into
- case True of True { ... }
- which stupidly tries to bind the datacon 'True'.
--}
-
--- NB: Make sure the argument is not levity polymorphic
-mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
-mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2
- | f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2)
- = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
- where
- case_bndr = case arg1 of
- Var v1 | isInternalName (idName v1)
- -> v1 -- Note [Desugaring seq], points (2) and (3)
- _ -> mkWildValBinder ty1
-
-mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore
-
--- NB: No argument can be levity polymorphic
-mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
-mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args
-
-mkCastDs :: CoreExpr -> Coercion -> CoreExpr
--- We define a desugarer-specific version of CoreUtils.mkCast,
--- because in the immediate output of the desugarer, we can have
--- apparently-mis-matched coercions: E.g.
--- let a = b
--- in (x :: a) |> (co :: b ~ Int)
--- Lint know about type-bindings for let and does not complain
--- So here we do not make the assertion checks that we make in
--- CoreUtils.mkCast; and we do less peephole optimisation too
-mkCastDs e co | isReflCo co = e
- | otherwise = Cast e co
-
-{-
-************************************************************************
-* *
- Tuples and selector bindings
-* *
-************************************************************************
-
-This is used in various places to do with lazy patterns.
-For each binder $b$ in the pattern, we create a binding:
-\begin{verbatim}
- b = case v of pat' -> b'
-\end{verbatim}
-where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
-
-ToDo: making these bindings should really depend on whether there's
-much work to be done per binding. If the pattern is complex, it
-should be de-mangled once, into a tuple (and then selected from).
-Otherwise the demangling can be in-line in the bindings (as here).
-
-Boring! Boring! One error message per binder. The above ToDo is
-even more helpful. Something very similar happens for pattern-bound
-expressions.
-
-Note [mkSelectorBinds]
-~~~~~~~~~~~~~~~~~~~~~~
-mkSelectorBinds is used to desugar a pattern binding {p = e},
-in a binding group:
- let { ...; p = e; ... } in body
-where p binds x,y (this list of binders can be empty).
-There are two cases.
-
------- Special case (A) -------
- For a pattern that is just a variable,
- let !x = e in body
- ==>
- let x = e in x `seq` body
- So we return the binding, with 'x' as the variable to seq.
-
------- Special case (B) -------
- For a pattern that is essentially just a tuple:
- * A product type, so cannot fail
- * Only one level, so that
- - generating multiple matches is fine
- - seq'ing it evaluates the same as matching it
- Then instead we generate
- { v = e
- ; x = case v of p -> x
- ; y = case v of p -> y }
- with 'v' as the variable to force
-
------- General case (C) -------
- In the general case we generate these bindings:
- let { ...; p = e; ... } in body
- ==>
- let { t = case e of p -> (x,y)
- ; x = case t of (x,y) -> x
- ; y = case t of (x,y) -> y }
- in t `seq` body
-
- Note that we return 't' as the variable to force if the pattern
- is strict (i.e. with -XStrict or an outermost-bang-pattern)
-
- Note that (A) /includes/ the situation where
-
- * The pattern binds exactly one variable
- let !(Just (Just x) = e in body
- ==>
- let { t = case e of Just (Just v) -> Unit v
- ; v = case t of Unit v -> v }
- in t `seq` body
- The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn
- Note that forcing 't' makes the pattern match happen,
- but does not force 'v'.
-
- * The pattern binds no variables
- let !(True,False) = e in body
- ==>
- let t = case e of (True,False) -> ()
- in t `seq` body
-
-
------- Examples ----------
- * !(_, (_, a)) = e
- ==>
- t = case e of (_, (_, a)) -> Unit a
- a = case t of Unit a -> a
-
- Note that
- - Forcing 't' will force the pattern to match fully;
- e.g. will diverge if (snd e) is bottom
- - But 'a' itself is not forced; it is wrapped in a one-tuple
- (see Note [One-tuples] in TysWiredIn)
-
- * !(Just x) = e
- ==>
- t = case e of Just x -> Unit x
- x = case t of Unit x -> x
-
- Again, forcing 't' will fail if 'e' yields Nothing.
-
-Note that even though this is rather general, the special cases
-work out well:
-
-* One binder, not -XStrict:
-
- let Just (Just v) = e in body
- ==>
- let t = case e of Just (Just v) -> Unit v
- v = case t of Unit v -> v
- in body
- ==>
- let v = case (case e of Just (Just v) -> Unit v) of
- Unit v -> v
- in body
- ==>
- let v = case e of Just (Just v) -> v
- in body
-
-* Non-recursive, -XStrict
- let p = e in body
- ==>
- let { t = case e of p -> (x,y)
- ; x = case t of (x,y) -> x
- ; y = case t of (x,y) -> x }
- in t `seq` body
- ==> {inline seq, float x,y bindings inwards}
- let t = case e of p -> (x,y) in
- case t of t' ->
- let { x = case t' of (x,y) -> x
- ; y = case t' of (x,y) -> x } in
- body
- ==> {inline t, do case of case}
- case e of p ->
- let t = (x,y) in
- let { x = case t' of (x,y) -> x
- ; y = case t' of (x,y) -> x } in
- body
- ==> {case-cancellation, drop dead code}
- case e of p -> body
-
-* Special case (B) is there to avoid fruitlessly taking the tuple
- apart and rebuilding it. For example, consider
- { K x y = e }
- where K is a product constructor. Then general case (A) does:
- { t = case e of K x y -> (x,y)
- ; x = case t of (x,y) -> x
- ; y = case t of (x,y) -> y }
- In the lazy case we can't optimise out this fruitless taking apart
- and rebuilding. Instead (B) builds
- { v = e
- ; x = case v of K x y -> x
- ; y = case v of K x y -> y }
- which is better.
--}
-
-mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
- -> LPat GhcTc -- ^ The pattern
- -> CoreExpr -- ^ Expression to which the pattern is bound
- -> DsM (Id,[(Id,CoreExpr)])
- -- ^ Id the rhs is bound to, for desugaring strict
- -- binds (see Note [Desugar Strict binds] in DsBinds)
- -- and all the desugared binds
-
-mkSelectorBinds ticks pat val_expr
- | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A)
- = return (v, [(v, val_expr)])
-
- | is_flat_prod_lpat pat' -- Special case (B)
- = do { let pat_ty = hsLPatType pat'
- ; val_var <- newSysLocalDsNoLP pat_ty
-
- ; let mk_bind tick bndr_var
- -- (mk_bind sv bv) generates bv = case sv of { pat -> bv }
- -- Remember, 'pat' binds 'bv'
- = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
- (Var bndr_var)
- (Var bndr_var) -- Neat hack
- -- Neat hack: since 'pat' can't fail, the
- -- "fail-expr" passed to matchSimply is not
- -- used. But it /is/ used for its type, and for
- -- that bndr_var is just the ticket.
- ; return (bndr_var, mkOptTickBox tick rhs_expr) }
-
- ; binds <- zipWithM mk_bind ticks' binders
- ; return ( val_var, (val_var, val_expr) : binds) }
-
- | otherwise -- General case (C)
- = do { tuple_var <- newSysLocalDs tuple_ty
- ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
- ; tuple_expr <- matchSimply val_expr PatBindRhs pat
- local_tuple error_expr
- ; let mk_tup_bind tick binder
- = (binder, mkOptTickBox tick $
- mkTupleSelector1 local_binders binder
- tuple_var (Var tuple_var))
- tup_binds = zipWith mk_tup_bind ticks' binders
- ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }
- where
- pat' = strip_bangs pat
- -- Strip the bangs before looking for case (A) or (B)
- -- The incoming pattern may well have a bang on it
-
- binders = collectPatBinders pat'
- ticks' = ticks ++ repeat []
-
- local_binders = map localiseId binders -- See Note [Localise pattern binders]
- local_tuple = mkBigCoreVarTup1 binders
- tuple_ty = exprType local_tuple
-
-strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
--- Remove outermost bangs and parens
-strip_bangs (L _ (ParPat _ p)) = strip_bangs p
-strip_bangs (L _ (BangPat _ p)) = strip_bangs p
-strip_bangs lp = lp
-
-is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
-is_flat_prod_lpat = is_flat_prod_pat . unLoc
-
-is_flat_prod_pat :: Pat (GhcPass p) -> Bool
-is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p
-is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
-is_flat_prod_pat (ConPatOut { pat_con = L _ pcon
- , pat_args = ps})
- | RealDataCon con <- pcon
- , isProductTyCon (dataConTyCon con)
- = all is_triv_lpat (hsConPatArgs ps)
-is_flat_prod_pat _ = False
-
-is_triv_lpat :: LPat (GhcPass p) -> Bool
-is_triv_lpat = is_triv_pat . unLoc
-
-is_triv_pat :: Pat (GhcPass p) -> Bool
-is_triv_pat (VarPat {}) = True
-is_triv_pat (WildPat{}) = True
-is_triv_pat (ParPat _ p) = is_triv_lpat p
-is_triv_pat _ = False
-
-
-{- *********************************************************************
-* *
- Creating big tuples and their types for full Haskell expressions.
- They work over *Ids*, and create tuples replete with their types,
- which is whey they are not in GHC.Hs.Utils.
-* *
-********************************************************************* -}
-
-mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
-mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
-mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats = L (getLoc (head lpats)) $
- mkVanillaTuplePat lpats Boxed
-
-mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
--- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
-
--- The Big equivalents for the source tuple expressions
-mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
-mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
-
-mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
-mkBigLHsTupId = mkChunkified mkLHsTupleExpr
-
--- The Big equivalents for the source tuple patterns
-mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
-mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
-
-mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
-mkBigLHsPatTupId = mkChunkified mkLHsPatTup
-
-{-
-************************************************************************
-* *
- Code for pattern-matching and other failures
-* *
-************************************************************************
-
-Generally, we handle pattern matching failure like this: let-bind a
-fail-variable, and use that variable if the thing fails:
-\begin{verbatim}
- let fail.33 = error "Help"
- in
- case x of
- p1 -> ...
- p2 -> fail.33
- p3 -> fail.33
- p4 -> ...
-\end{verbatim}
-Then
-\begin{itemize}
-\item
-If the case can't fail, then there'll be no mention of @fail.33@, and the
-simplifier will later discard it.
-
-\item
-If it can fail in only one way, then the simplifier will inline it.
-
-\item
-Only if it is used more than once will the let-binding remain.
-\end{itemize}
-
-There's a problem when the result of the case expression is of
-unboxed type. Then the type of @fail.33@ is unboxed too, and
-there is every chance that someone will change the let into a case:
-\begin{verbatim}
- case error "Help" of
- fail.33 -> case ....
-\end{verbatim}
-
-which is of course utterly wrong. Rather than drop the condition that
-only boxed types can be let-bound, we just turn the fail into a function
-for the primitive case:
-\begin{verbatim}
- let fail.33 :: Void -> Int#
- fail.33 = \_ -> error "Help"
- in
- case x of
- p1 -> ...
- p2 -> fail.33 void
- p3 -> fail.33 void
- p4 -> ...
-\end{verbatim}
-
-Now @fail.33@ is a function, so it can be let-bound.
-
-We would *like* to use join points here; in fact, these "fail variables" are
-paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as
-CPS functions - i.e. they take "join points" as parameters. It's not impossible
-to imagine extending our type system to allow passing join points around (very
-carefully), but we certainly don't support it now.
-
-99.99% of the time, the fail variables wind up as join points in short order
-anyway, and the Void# doesn't do much harm.
--}
-
-mkFailurePair :: CoreExpr -- Result type of the whole case expression
- -> DsM (CoreBind, -- Binds the newly-created fail variable
- -- to \ _ -> expression
- CoreExpr) -- Fail variable applied to realWorld#
--- See Note [Failure thunks and CPR]
-mkFailurePair expr
- = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty)
- ; fail_fun_arg <- newSysLocalDs voidPrimTy
- ; let real_arg = setOneShotLambda fail_fun_arg
- ; return (NonRec fail_fun_var (Lam real_arg expr),
- App (Var fail_fun_var) (Var voidPrimId)) }
- where
- ty = exprType expr
-
-{-
-Note [Failure thunks and CPR]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-(This note predates join points as formal entities (hence the quotation marks).
-We can't use actual join points here (see above); if we did, this would also
-solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR
-join points] in WorkWrap.)
-
-When we make a failure point we ensure that it
-does not look like a thunk. Example:
-
- let fail = \rw -> error "urk"
- in case x of
- [] -> fail realWorld#
- (y:ys) -> case ys of
- [] -> fail realWorld#
- (z:zs) -> (y,z)
-
-Reason: we know that a failure point is always a "join point" and is
-entered at most once. Adding a dummy 'realWorld' token argument makes
-it clear that sharing is not an issue. And that in turn makes it more
-CPR-friendly. This matters a lot: if you don't get it right, you lose
-the tail call property. For example, see #3403.
-
-
-************************************************************************
-* *
- Ticks
-* *
-********************************************************************* -}
-
-mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
-mkOptTickBox = flip (foldr Tick)
-
-mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
-mkBinaryTickBox ixT ixF e = do
- uq <- newUnique
- this_mod <- getModule
- let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
- let
- falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
- trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId)
- --
- return $ Case e bndr1 boolTy
- [ (DataAlt falseDataCon, [], falseBox)
- , (DataAlt trueDataCon, [], trueBox)
- ]
-
-
-
--- *******************************************************************
-
-{- Note [decideBangHood]
-~~~~~~~~~~~~~~~~~~~~~~~~
-With -XStrict we may make /outermost/ patterns more strict.
-E.g.
- let (Just x) = e in ...
- ==>
- let !(Just x) = e in ...
-and
- f x = e
- ==>
- f !x = e
-
-This adjustment is done by decideBangHood,
-
- * Just before constructing an EqnInfo, in Match
- (matchWrapper and matchSinglePat)
-
- * When desugaring a pattern-binding in DsBinds.dsHsBind
-
-Note that it is /not/ done recursively. See the -XStrict
-spec in the user manual.
-
-Specifically:
- ~pat => pat -- when -XStrict (even if pat = ~pat')
- !pat => !pat -- always
- pat => !pat -- when -XStrict
- pat => pat -- otherwise
--}
-
-
--- | Use -XStrict to add a ! or remove a ~
--- See Note [decideBangHood]
-decideBangHood :: DynFlags
- -> LPat GhcTc -- ^ Original pattern
- -> LPat GhcTc -- Pattern with bang if necessary
-decideBangHood dflags lpat
- | not (xopt LangExt.Strict dflags)
- = lpat
- | otherwise -- -XStrict
- = go lpat
- where
- go lp@(L l p)
- = case p of
- ParPat x p -> L l (ParPat x (go p))
- LazyPat _ lp' -> lp'
- BangPat _ _ -> lp
- _ -> L l (BangPat noExtField lp)
-
--- | Unconditionally make a 'Pat' strict.
-addBang :: LPat GhcTc -- ^ Original pattern
- -> LPat GhcTc -- ^ Banged pattern
-addBang = go
- where
- go lp@(L l p)
- = case p of
- ParPat x p -> L l (ParPat x (go p))
- LazyPat _ lp' -> L l (BangPat noExtField lp')
- -- Should we bring the extension value over?
- BangPat _ _ -> lp
- _ -> L l (BangPat noExtField lp)
-
-isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-
--- Returns Just {..} if we're sure that the expression is True
--- I.e. * 'True' datacon
--- * 'otherwise' Id
--- * Trivial wappings of these
--- The arguments to Just are any HsTicks that we have found,
--- because we still want to tick then, even it they are always evaluated.
-isTrueLHsExpr (L _ (HsVar _ (L _ v)))
- | v `hasKey` otherwiseIdKey
- || v `hasKey` getUnique trueDataConId
- = Just return
- -- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (L _ (HsConLikeOut _ con))
- | con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (L _ (HsTick _ tickish e))
- | Just ticks <- isTrueLHsExpr e
- = Just (\x -> do wrapped <- ticks x
- return (Tick tickish wrapped))
- -- This encodes that the result is constant True for Hpc tick purposes;
- -- which is specifically what isTrueLHsExpr is trying to find out.
-isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
- | Just ticks <- isTrueLHsExpr e
- = Just (\x -> do e <- ticks x
- this_mod <- getModule
- return (Tick (HpcTick this_mod ixT) e))
-
-isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e
-isTrueLHsExpr _ = Nothing
diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs
deleted file mode 100644
index 632207c41f..0000000000
--- a/compiler/deSugar/ExtractDocs.hs
+++ /dev/null
@@ -1,360 +0,0 @@
--- | Extract docs from the renamer output so they can be be serialized.
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-module ExtractDocs (extractDocs) where
-
-import GhcPrelude
-import Bag
-import GHC.Hs.Binds
-import GHC.Hs.Doc
-import GHC.Hs.Decls
-import GHC.Hs.Extension
-import GHC.Hs.Types
-import GHC.Hs.Utils
-import Name
-import NameSet
-import SrcLoc
-import TcRnTypes
-
-import Control.Applicative
-import Data.Bifunctor (first)
-import Data.List
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Maybe
-import Data.Semigroup
-
--- | Extract docs from renamer output.
-extractDocs :: TcGblEnv
- -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
- -- ^
- -- 1. Module header
- -- 2. Docs on top level declarations
- -- 3. Docs on arguments
-extractDocs TcGblEnv { tcg_semantic_mod = mod
- , tcg_rn_decls = mb_rn_decls
- , tcg_insts = insts
- , tcg_fam_insts = fam_insts
- , tcg_doc_hdr = mb_doc_hdr
- } =
- (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map)
- where
- (doc_map, arg_map) = maybe (M.empty, M.empty)
- (mkMaps local_insts)
- mb_decls_with_docs
- mb_decls_with_docs = topDecls <$> mb_rn_decls
- local_insts = filter (nameIsLocalOrFrom mod)
- $ map getName insts ++ map getName fam_insts
-
--- | Create decl and arg doc-maps by looping through the declarations.
--- For each declaration, find its names, its subordinates, and its doc strings.
-mkMaps :: [Name]
- -> [(LHsDecl GhcRn, [HsDocString])]
- -> (Map Name (HsDocString), Map Name (Map Int (HsDocString)))
-mkMaps instances decls =
- ( f' (map (nubByName fst) decls')
- , f (filterMapping (not . M.null) args)
- )
- where
- (decls', args) = unzip (map mappings decls)
-
- f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
- f = M.fromListWith (<>) . concat
-
- f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString
- f' = M.fromListWith appendDocs . concat
-
- filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]]
- filterMapping p = map (filter (p . snd))
-
- mappings :: (LHsDecl GhcRn, [HsDocString])
- -> ( [(Name, HsDocString)]
- , [(Name, Map Int (HsDocString))]
- )
- mappings (L l decl, docStrs) =
- (dm, am)
- where
- doc = concatDocs docStrs
- args = declTypeDocs decl
-
- subs :: [(Name, [(HsDocString)], Map Int (HsDocString))]
- subs = subordinates instanceMap decl
-
- (subDocs, subArgs) =
- unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)
-
- ns = names l decl
- subNs = [ n | (n, _, _) <- subs ]
- dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]
- am = [(n, args) | n <- ns] ++ zip subNs subArgs
-
- instanceMap :: Map SrcSpan Name
- instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances]
-
- names :: SrcSpan -> HsDecl GhcRn -> [Name]
- names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See
- -- Note [1].
- where loc = case d of
- TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only
- -- for TFs
- _ -> getInstLoc d
- names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
- names _ decl = getMainDeclBinder decl
-
-{-
-Note [1]:
----------
-We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
-inside them. That should work for normal user-written instances (from
-looking at GHC sources). We can assume that commented instances are
-user-written. This lets us relate Names (from ClsInsts) to comments
-(associated with InstDecls and DerivDecls).
--}
-
-getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
-getMainDeclBinder (TyClD _ d) = [tcdName d]
-getMainDeclBinder (ValD _ d) =
- case collectHsBindBinders d of
- [] -> []
- (name:_) -> [name]
-getMainDeclBinder (SigD _ d) = sigNameNoLoc d
-getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
-getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
-getMainDeclBinder _ = []
-
-sigNameNoLoc :: Sig pass -> [IdP pass]
-sigNameNoLoc (TypeSig _ ns _) = map unLoc ns
-sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns
-sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns
-sigNameNoLoc (SpecSig _ n _ _) = [unLoc n]
-sigNameNoLoc (InlineSig _ n _) = [unLoc n]
-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
-sigNameNoLoc _ = []
-
--- Extract the source location where an instance is defined. This is used
--- to correlate InstDecls with their Instance/CoAxiom Names, via the
--- instanceMap.
-getInstLoc :: InstDecl (GhcPass p) -> SrcSpan
-getInstLoc = \case
- ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
- DataFamInstD _ (DataFamInstDecl
- { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l
- TyFamInstD _ (TyFamInstDecl
- -- Since CoAxioms' Names refer to the whole line for type family instances
- -- in particular, we need to dig a bit deeper to pull out the entire
- -- equation. This does not happen for data family instances, for some
- -- reason.
- { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l
- ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"
- DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
- TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
- XInstDecl _ -> error "getInstLoc"
- DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
- TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
-
--- | Get all subordinate declarations inside a declaration, and their docs.
--- A subordinate declaration is something like the associate type or data
--- family of a type class.
-subordinates :: Map SrcSpan Name
- -> HsDecl GhcRn
- -> [(Name, [(HsDocString)], Map Int (HsDocString))]
-subordinates instMap decl = case decl of
- InstD _ (ClsInstD _ d) -> do
- DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
- FamEqn { feqn_tycon = L l _
- , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
- [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
-
- InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
- -> dataSubs (feqn_rhs d)
- TyClD _ d | isClassDecl d -> classSubs d
- | isDataDecl d -> dataSubs (tcdDataDefn d)
- _ -> []
- where
- classSubs dd = [ (name, doc, declTypeDocs d)
- | (L _ d, doc) <- classDecls dd
- , name <- getMainDeclBinder d, not (isValD d)
- ]
- dataSubs :: HsDataDefn GhcRn
- -> [(Name, [HsDocString], Map Int (HsDocString))]
- dataSubs dd = constrs ++ fields ++ derivs
- where
- cons = map unLoc $ (dd_cons dd)
- constrs = [ ( unLoc cname
- , maybeToList $ fmap unLoc $ con_doc c
- , conArgDocs c)
- | c <- cons, cname <- getConNames c ]
- fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
- | RecCon flds <- map getConArgs cons
- , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
- , (L _ n) <- ns ]
- derivs = [ (instName, [unLoc doc], M.empty)
- | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
- concatMap (unLoc . deriv_clause_tys . unLoc) $
- unLoc $ dd_derivs dd
- , Just instName <- [M.lookup l instMap] ]
-
- extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
- extract_deriv_ty (L l ty) =
- case ty of
- -- deriving (forall a. C a {- ^ Doc comment -})
- HsForAllTy{ hst_fvf = ForallInvis
- , hst_body = L _ (HsDocTy _ _ doc) }
- -> Just (l, doc)
- -- deriving (C a {- ^ Doc comment -})
- HsDocTy _ _ doc -> Just (l, doc)
- _ -> Nothing
-
--- | Extract constructor argument docs from inside constructor decls.
-conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
-conArgDocs con = case getConArgs con of
- PrefixCon args -> go 0 (map unLoc args ++ ret)
- InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
- RecCon _ -> go 1 ret
- where
- go n = M.fromList . catMaybes . zipWith f [n..]
- where
- f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
- f _ _ = Nothing
-
- ret = case con of
- ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
- _ -> []
-
-isValD :: HsDecl a -> Bool
-isValD (ValD _ _) = True
-isValD _ = False
-
--- | All the sub declarations of a class (that we handle), ordered by
--- source location, with documentation attached if it exists.
-classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
- where
- decls = docs ++ defs ++ sigs ++ ats
- docs = mkDecls tcdDocs (DocD noExtField) class_
- defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_
- sigs = mkDecls tcdSigs (SigD noExtField) class_
- ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_
-
--- | Extract function argument docs from inside top-level decls.
-declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)
-declTypeDocs = \case
- SigD _ (TypeSig _ _ ty) -> typeDocs (unLoc (hsSigWcType ty))
- SigD _ (ClassOpSig _ _ _ ty) -> typeDocs (unLoc (hsSigType ty))
- SigD _ (PatSynSig _ _ ty) -> typeDocs (unLoc (hsSigType ty))
- ForD _ (ForeignImport _ _ ty _) -> typeDocs (unLoc (hsSigType ty))
- TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
- _ -> M.empty
-
-nubByName :: (a -> Name) -> [a] -> [a]
-nubByName f ns = go emptyNameSet ns
- where
- go _ [] = []
- go s (x:xs)
- | y `elemNameSet` s = go s xs
- | otherwise = let s' = extendNameSet s y
- in x : go s' xs
- where
- y = f x
-
--- | Extract function argument docs from inside types.
-typeDocs :: HsType GhcRn -> Map Int (HsDocString)
-typeDocs = go 0
- where
- go n = \case
- HsForAllTy { hst_body = ty } -> go n (unLoc ty)
- HsQualTy { hst_body = ty } -> go n (unLoc ty)
- HsFunTy _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty)
- HsFunTy _ _ ty -> go (n+1) (unLoc ty)
- HsDocTy _ _ doc -> M.singleton n (unLoc doc)
- _ -> M.empty
-
--- | The top-level declarations of a module that we care about,
--- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
-topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
-
--- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
-ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
-ungroup group_ =
- mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++
- mkDecls hs_derivds (DerivD noExtField) group_ ++
- mkDecls hs_defds (DefD noExtField) group_ ++
- mkDecls hs_fords (ForD noExtField) group_ ++
- mkDecls hs_docs (DocD noExtField) group_ ++
- mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++
- mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++
- mkDecls (valbinds . hs_valds) (ValD noExtField) group_
- where
- typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig
- typesigs ValBinds{} = error "expected XValBindsLR"
-
- valbinds (XValBindsLR (NValBinds binds _)) =
- concatMap bagToList . snd . unzip $ binds
- valbinds ValBinds{} = error "expected XValBindsLR"
-
--- | Sort by source location
-sortByLoc :: [Located a] -> [Located a]
-sortByLoc = sortOn getLoc
-
--- | Collect docs and attach them to the right declarations.
---
--- A declaration may have multiple doc strings attached to it.
-collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])]
--- ^ This is an example.
-collectDocs = go [] Nothing
- where
- go docs mprev decls = case (decls, mprev) of
- ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds
- ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds
- ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds
- (d : ds, Nothing) -> go docs (Just d) ds
- (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds
- ([] , Nothing) -> []
- ([] , Just prev) -> finished prev docs []
-
- finished decl docs rest = (decl, reverse docs) : rest
-
--- | Filter out declarations that we don't handle in Haddock
-filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls = filter (isHandled . unLoc . fst)
- where
- isHandled (ForD _ (ForeignImport {})) = True
- isHandled (TyClD {}) = True
- isHandled (InstD {}) = True
- isHandled (DerivD {}) = True
- isHandled (SigD _ d) = isUserSig d
- isHandled (ValD {}) = True
- -- we keep doc declarations to be able to get at named docs
- isHandled (DocD {}) = True
- isHandled _ = False
-
-
--- | Go through all class declarations and filter their sub-declarations
-filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterClasses = map (first (mapLoc filterClass))
- where
- filterClass (TyClD x c@(ClassDecl {})) =
- TyClD x $ c { tcdSigs =
- filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
- filterClass d = d
-
--- | Was this signature given by the user?
-isUserSig :: Sig name -> Bool
-isUserSig TypeSig {} = True
-isUserSig ClassOpSig {} = True
-isUserSig PatSynSig {} = True
-isUserSig _ = False
-
--- | Take a field of declarations from a data structure and create HsDecls
--- using the given constructor
-mkDecls :: (struct -> [Located decl])
- -> (decl -> hsDecl)
- -> struct
- -> [Located hsDecl]
-mkDecls field con = map (mapLoc con) . field
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
deleted file mode 100644
index d6ddfb894a..0000000000
--- a/compiler/deSugar/Match.hs
+++ /dev/null
@@ -1,1148 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-The @match@ function
--}
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE MonadComprehensions #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-module Match ( match, matchEquations, matchWrapper, matchSimply
- , matchSinglePat, matchSinglePatVar ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr)
-
-import BasicTypes ( Origin(..) )
-import DynFlags
-import GHC.Hs
-import TcHsSyn
-import TcEvidence
-import TcRnMonad
-import GHC.HsToCore.PmCheck
-import CoreSyn
-import Literal
-import CoreUtils
-import MkCore
-import DsMonad
-import DsBinds
-import DsGRHSs
-import DsUtils
-import Id
-import ConLike
-import DataCon
-import PatSyn
-import MatchCon
-import MatchLit
-import Type
-import Coercion ( eqCoercion )
-import TyCon( isNewTyCon )
-import TysWiredIn
-import SrcLoc
-import Maybes
-import Util
-import Name
-import Outputable
-import BasicTypes ( isGenerated, il_value, fl_value )
-import FastString
-import Unique
-import UniqDFM
-
-import Control.Monad( when, unless )
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NEL
-import qualified Data.Map as Map
-
-{-
-************************************************************************
-* *
- The main matching function
-* *
-************************************************************************
-
-The function @match@ is basically the same as in the Wadler chapter
-from "The Implementation of Functional Programming Languages",
-except it is monadised, to carry around the name supply, info about
-annotations, etc.
-
-Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
-\begin{enumerate}
-\item
-A list of $n$ variable names, those variables presumably bound to the
-$n$ expressions being matched against the $n$ patterns. Using the
-list of $n$ expressions as the first argument showed no benefit and
-some inelegance.
-
-\item
-The second argument, a list giving the ``equation info'' for each of
-the $m$ equations:
-\begin{itemize}
-\item
-the $n$ patterns for that equation, and
-\item
-a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
-the front'' of the matching code, as in:
-\begin{verbatim}
-let <binds>
-in <matching-code>
-\end{verbatim}
-\item
-and finally: (ToDo: fill in)
-
-The right way to think about the ``after-match function'' is that it
-is an embryonic @CoreExpr@ with a ``hole'' at the end for the
-final ``else expression''.
-\end{itemize}
-
-There is a data type, @EquationInfo@, defined in module @DsMonad@.
-
-An experiment with re-ordering this information about equations (in
-particular, having the patterns available in column-major order)
-showed no benefit.
-
-\item
-A default expression---what to evaluate if the overall pattern-match
-fails. This expression will (almost?) always be
-a measly expression @Var@, unless we know it will only be used once
-(as we do in @glue_success_exprs@).
-
-Leaving out this third argument to @match@ (and slamming in lots of
-@Var "fail"@s) is a positively {\em bad} idea, because it makes it
-impossible to share the default expressions. (Also, it stands no
-chance of working in our post-upheaval world of @Locals@.)
-\end{enumerate}
-
-Note: @match@ is often called via @matchWrapper@ (end of this module),
-a function that does much of the house-keeping that goes with a call
-to @match@.
-
-It is also worth mentioning the {\em typical} way a block of equations
-is desugared with @match@. At each stage, it is the first column of
-patterns that is examined. The steps carried out are roughly:
-\begin{enumerate}
-\item
-Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
-bindings to the second component of the equation-info):
-\item
-Now {\em unmix} the equations into {\em blocks} [w\/ local function
-@match_groups@], in which the equations in a block all have the same
- match group.
-(see ``the mixture rule'' in SLPJ).
-\item
-Call the right match variant on each block of equations; it will do the
-appropriate thing for each kind of column-1 pattern.
-\end{enumerate}
-
-We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
-than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
-And gluing the ``success expressions'' together isn't quite so pretty.
-
-This @match@ uses @tidyEqnInfo@
-to get `as'- and `twiddle'-patterns out of the way (tidying), before
-applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em
-un}mixes the equations], producing a list of equation-info
-blocks, each block having as its first column patterns compatible with each other.
-
-Note [Match Ids]
-~~~~~~~~~~~~~~~~
-Most of the matching functions take an Id or [Id] as argument. This Id
-is the scrutinee(s) of the match. The desugared expression may
-sometimes use that Id in a local binding or as a case binder. So it
-should not have an External name; Lint rejects non-top-level binders
-with External names (#13043).
-
-See also Note [Localise pattern binders] in DsUtils
--}
-
-type MatchId = Id -- See Note [Match Ids]
-
-match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with. See Note [Match Ids]
- -> Type -- ^ Type of the case expression
- -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below)
- -> DsM MatchResult -- ^ Desugared result!
-
-match [] ty eqns
- = ASSERT2( not (null eqns), ppr ty )
- return (foldr1 combineMatchResults match_results)
- where
- match_results = [ ASSERT( null (eqn_pats eqn) )
- eqn_rhs eqn
- | eqn <- eqns ]
-
-match (v:vs) ty eqns -- Eqns *can* be empty
- = ASSERT2( all (isInternalName . idName) vars, ppr vars )
- do { dflags <- getDynFlags
- -- Tidy the first pattern, generating
- -- auxiliary bindings if necessary
- ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
- -- Group the equations and match each group in turn
- ; let grouped = groupEquations dflags tidy_eqns
-
- -- print the view patterns that are commoned up to help debug
- ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
-
- ; match_results <- match_groups grouped
- ; return (adjustMatchResult (foldr (.) id aux_binds) $
- foldr1 combineMatchResults match_results) }
- where
- vars = v :| vs
-
- dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
- dropGroup = fmap snd
-
- match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult)
- -- Result list of [MatchResult] is always non-empty
- match_groups [] = matchEmpty v ty
- match_groups (g:gs) = mapM match_group $ g :| gs
-
- match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM MatchResult
- match_group eqns@((group,_) :| _)
- = case group of
- PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
- PgSyn {} -> matchPatSyn vars ty (dropGroup eqns)
- PgLit {} -> matchLiterals vars ty (ne $ subGroupOrd [(l,e) | (PgLit l, e) <- eqns'])
- PgAny -> matchVariables vars ty (dropGroup eqns)
- PgN {} -> matchNPats vars ty (dropGroup eqns)
- PgOverS {}-> matchNPats vars ty (dropGroup eqns)
- PgNpK {} -> matchNPlusKPats vars ty (dropGroup eqns)
- PgBang -> matchBangs vars ty (dropGroup eqns)
- PgCo {} -> matchCoercion vars ty (dropGroup eqns)
- PgView {} -> matchView vars ty (dropGroup eqns)
- PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
- where eqns' = NEL.toList eqns
- ne l = case NEL.nonEmpty l of
- Just nel -> nel
- Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty"
-
- -- FIXME: we should also warn about view patterns that should be
- -- commoned up but are not
-
- -- print some stuff to see what's getting grouped
- -- use -dppr-debug to see the resolution of overloaded literals
- debug eqns =
- let gs = map (\group -> foldr (\ (p,_) -> \acc ->
- case p of PgView e _ -> e:acc
- _ -> acc) [] group) eqns
- maybeWarn [] = return ()
- maybeWarn l = warnDs NoReason (vcat l)
- in
- maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
- (filter (not . null) gs))
-
-matchEmpty :: MatchId -> Type -> DsM (NonEmpty MatchResult)
--- See Note [Empty case expressions]
-matchEmpty var res_ty
- = return [MatchResult CanFail mk_seq]
- where
- mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
- [(DEFAULT, [], fail)]
-
-matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
--- Real true variables, just like in matchVar, SLPJ p 94
--- No binding to do: they'll all be wildcards by now (done in tidy)
-matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns
-
-matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
-matchBangs (var :| vars) ty eqns
- = do { match_result <- match (var:vars) ty $ NEL.toList $
- decomposeFirstPat getBangPat <$> eqns
- ; return (mkEvalMatchResult var ty match_result) }
-
-matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
--- Apply the coercion to the match variable and then match that
-matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
- = do { let CoPat _ co pat _ = firstPat eqn1
- ; let pat_ty' = hsPatType pat
- ; var' <- newUniqueId var pat_ty'
- ; match_result <- match (var':vars) ty $ NEL.toList $
- decomposeFirstPat getCoPat <$> eqns
- ; core_wrap <- dsHsWrapper co
- ; let bind = NonRec var' (core_wrap (Var var))
- ; return (mkCoLetMatchResult bind match_result) }
-
-matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
--- Apply the view function to the match variable and then match that
-matchView (var :| vars) ty (eqns@(eqn1 :| _))
- = do { -- we could pass in the expr from the PgView,
- -- but this needs to extract the pat anyway
- -- to figure out the type of the fresh variable
- let ViewPat _ viewExpr (L _ pat) = firstPat eqn1
- -- do the rest of the compilation
- ; let pat_ty' = hsPatType pat
- ; var' <- newUniqueId var pat_ty'
- ; match_result <- match (var':vars) ty $ NEL.toList $
- decomposeFirstPat getViewPat <$> eqns
- -- compile the view expressions
- ; viewExpr' <- dsLExpr viewExpr
- ; return (mkViewMatchResult var'
- (mkCoreAppDs (text "matchView") viewExpr' (Var var))
- match_result) }
-
-matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult
-matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _))
--- Since overloaded list patterns are treated as view patterns,
--- the code is roughly the same as for matchView
- = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1
- ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand
- ; match_result <- match (var':vars) ty $ NEL.toList $
- decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
- ; e' <- dsSyntaxExpr e [Var var]
- ; return (mkViewMatchResult var' e' match_result)
- }
-
--- decompose the first pattern and leave the rest alone
-decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
-decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
- = eqn { eqn_pats = extractpat pat : pats}
-decomposeFirstPat _ _ = panic "decomposeFirstPat"
-
-getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
-getCoPat (CoPat _ _ pat _) = pat
-getCoPat _ = panic "getCoPat"
-getBangPat (BangPat _ pat ) = unLoc pat
-getBangPat _ = panic "getBangPat"
-getViewPat (ViewPat _ _ pat) = unLoc pat
-getViewPat _ = panic "getViewPat"
-getOLPat (ListPat (ListPatTc ty (Just _)) pats)
- = ListPat (ListPatTc ty Nothing) pats
-getOLPat _ = panic "getOLPat"
-
-{-
-Note [Empty case alternatives]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The list of EquationInfo can be empty, arising from
- case x of {} or \case {}
-In that situation we desugar to
- case x of { _ -> error "pattern match failure" }
-The *desugarer* isn't certain whether there really should be no
-alternatives, so it adds a default case, as it always does. A later
-pass may remove it if it's inaccessible. (See also Note [Empty case
-alternatives] in CoreSyn.)
-
-We do *not* desugar simply to
- error "empty case"
-or some such, because 'x' might be bound to (error "hello"), in which
-case we want to see that "hello" exception, not (error "empty case").
-See also Note [Case elimination: lifted case] in Simplify.
-
-
-************************************************************************
-* *
- Tidying patterns
-* *
-************************************************************************
-
-Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
-which will be scrutinised.
-
-This makes desugaring the pattern match simpler by transforming some of
-the patterns to simpler forms. (Tuples to Constructor Patterns)
-
-Among other things in the resulting Pattern:
-* Variables and irrefutable(lazy) patterns are replaced by Wildcards
-* As patterns are replaced by the patterns they wrap.
-
-The bindings created by the above patterns are put into the returned wrapper
-instead.
-
-This means a definition of the form:
- f x = rhs
-when called with v get's desugared to the equivalent of:
- let x = v
- in
- f _ = rhs
-
-The same principle holds for as patterns (@) and
-irrefutable/lazy patterns (~).
-In the case of irrefutable patterns the irrefutable pattern is pushed into
-the binding.
-
-Pattern Constructors which only represent syntactic sugar are converted into
-their desugared representation.
-This usually means converting them to Constructor patterns but for some
-depends on enabled extensions. (Eg OverloadedLists)
-
-GHC also tries to convert overloaded Literals into regular ones.
-
-The result of this tidying is that the column of patterns will include
-only these which can be assigned a PatternGroup (see patGroup).
-
--}
-
-tidyEqnInfo :: Id -> EquationInfo
- -> DsM (DsWrapper, EquationInfo)
- -- DsM'd because of internal call to dsLHsBinds
- -- and mkSelectorBinds.
- -- "tidy1" does the interesting stuff, looking at
- -- one pattern and fiddling the list of bindings.
- --
- -- POST CONDITION: head pattern in the EqnInfo is
- -- one of these for which patGroup is defined.
-
-tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
- = panic "tidyEqnInfo"
-
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
- = do { (wrap, pat') <- tidy1 v orig pat
- ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
-
-tidy1 :: Id -- The Id being scrutinised
- -> Origin -- Was this a pattern the user wrote?
- -> Pat GhcTc -- The pattern against which it is to be matched
- -> DsM (DsWrapper, -- Extra bindings to do before the match
- Pat GhcTc) -- Equivalent pattern
-
--------------------------------------------------------
--- (pat', mr') = tidy1 v pat mr
--- tidies the *outer level only* of pat, giving pat'
--- It eliminates many pattern forms (as-patterns, variable patterns,
--- list patterns, etc) and returns any created bindings in the wrapper.
-
-tidy1 v o (ParPat _ pat) = tidy1 v o (unLoc pat)
-tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat)
-tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty)
-tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
-
- -- case v of { x -> mr[] }
- -- = case v of { _ -> let x=v in mr[] }
-tidy1 v _ (VarPat _ (L _ var))
- = return (wrapBind var v, WildPat (idType var))
-
- -- case v of { x@p -> mr[] }
- -- = case v of { p -> let x=v in mr[] }
-tidy1 v o (AsPat _ (L _ var) pat)
- = do { (wrap, pat') <- tidy1 v o (unLoc pat)
- ; return (wrapBind var v . wrap, pat') }
-
-{- now, here we handle lazy patterns:
- tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
- v2 = case v of p -> v2 : ... : bs )
-
- where the v_i's are the binders in the pattern.
-
- ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
-
- The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
--}
-
-tidy1 v _ (LazyPat _ pat)
- -- This is a convenient place to check for unlifted types under a lazy pattern.
- -- Doing this check during type-checking is unsatisfactory because we may
- -- not fully know the zonked types yet. We sure do here.
- = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)
- ; unless (null unlifted_bndrs) $
- putSrcSpanDs (getLoc pat) $
- errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$
- text "Unlifted variables:")
- 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))
- unlifted_bndrs)))
-
- ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
- ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
- ; return (mkCoreLets sel_binds, WildPat (idType v)) }
-
-tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats )
- = return (idDsWrapper, unLoc list_ConPat)
- where
- list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
- (mkNilPat ty)
- pats
-
-tidy1 _ _ (TuplePat tys pats boxity)
- = return (idDsWrapper, unLoc tuple_ConPat)
- where
- arity = length pats
- tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
-
-tidy1 _ _ (SumPat tys pat alt arity)
- = return (idDsWrapper, unLoc sum_ConPat)
- where
- sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys
-
--- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (LitPat _ lit)
- = do { unless (isGenerated o) $
- warnAboutOverflowedLit lit
- ; return (idDsWrapper, tidyLitPat lit) }
-
--- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
- = do { unless (isGenerated o) $
- let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
- | otherwise = lit
- in warnAboutOverflowedOverLit lit'
- ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
-
--- NPlusKPat: we may want to warn about the literals
-tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
- = do { unless (isGenerated o) $ do
- warnAboutOverflowedOverLit lit1
- warnAboutOverflowedOverLit lit2
- ; return (idDsWrapper, n) }
-
--- Everything else goes through unchanged...
-tidy1 _ _ non_interesting_pat
- = return (idDsWrapper, non_interesting_pat)
-
---------------------
-tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc
- -> DsM (DsWrapper, Pat GhcTc)
-
--- Discard par/sig under a bang
-tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p
-tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
-
--- Push the bang-pattern inwards, in the hope that
--- it may disappear next time
-tidy_bang_pat v o l (AsPat x v' p)
- = tidy1 v o (AsPat x v' (L l (BangPat noExtField p)))
-tidy_bang_pat v o l (CoPat x w p t)
- = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t)
-
--- Discard bang around strict pattern
-tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(ListPat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p
-tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p
-
--- Data/newtype constructors
-tidy_bang_pat v o l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
- , pat_args = args
- , pat_arg_tys = arg_tys })
- -- Newtypes: push bang inwards (#9844)
- =
- if isNewTyCon (dataConTyCon dc)
- then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l ty args })
- else tidy1 v o p -- Data types: discard the bang
- where
- (ty:_) = dataConInstArgTys dc arg_tys
-
--------------------
--- Default case, leave the bang there:
--- VarPat,
--- LazyPat,
--- WildPat,
--- ViewPat,
--- pattern synonyms (ConPatOut with PatSynCon)
--- NPat,
--- NPlusKPat
---
--- For LazyPat, remember that it's semantically like a VarPat
--- i.e. !(~p) is not like ~p, or p! (#8952)
---
--- NB: SigPatIn, ConPatIn should not happen
-
-tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))
-
--------------------
-push_bang_into_newtype_arg :: SrcSpan
- -> Type -- The type of the argument we are pushing
- -- onto
- -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
--- See Note [Bang patterns and newtypes]
--- We are transforming !(N p) into (N !p)
-push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
- = ASSERT( null args)
- PrefixCon [L l (BangPat noExtField arg)]
-push_bang_into_newtype_arg l _ty (RecCon rf)
- | HsRecFields { rec_flds = L lf fld : flds } <- rf
- , HsRecField { hsRecFieldArg = arg } <- fld
- = ASSERT( null flds)
- RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
- = L l (BangPat noExtField arg) })] })
-push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
- | HsRecFields { rec_flds = [] } <- rf
- = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))]
-push_bang_into_newtype_arg _ _ cd
- = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
-
-{-
-Note [Bang patterns and newtypes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For the pattern !(Just pat) we can discard the bang, because
-the pattern is strict anyway. But for !(N pat), where
- newtype NT = N Int
-we definitely can't discard the bang. #9844.
-
-So what we do is to push the bang inwards, in the hope that it will
-get discarded there. So we transform
- !(N pat) into (N !pat)
-
-But what if there is nothing to push the bang onto? In at least one instance
-a user has written !(N {}) which we translate into (N !_). See #13215
-
-
-\noindent
-{\bf Previous @matchTwiddled@ stuff:}
-
-Now we get to the only interesting part; note: there are choices for
-translation [from Simon's notes]; translation~1:
-\begin{verbatim}
-deTwiddle [s,t] e
-\end{verbatim}
-returns
-\begin{verbatim}
-[ w = e,
- s = case w of [s,t] -> s
- t = case w of [s,t] -> t
-]
-\end{verbatim}
-
-Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
-evaluation of \tr{e}. An alternative translation (No.~2):
-\begin{verbatim}
-[ w = case e of [s,t] -> (s,t)
- s = case w of (s,t) -> s
- t = case w of (s,t) -> t
-]
-\end{verbatim}
-
-************************************************************************
-* *
-\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
-* *
-************************************************************************
-
-We might be able to optimise unmixing when confronted by
-only-one-constructor-possible, of which tuples are the most notable
-examples. Consider:
-\begin{verbatim}
-f (a,b,c) ... = ...
-f d ... (e:f) = ...
-f (g,h,i) ... = ...
-f j ... = ...
-\end{verbatim}
-This definition would normally be unmixed into four equation blocks,
-one per equation. But it could be unmixed into just one equation
-block, because if the one equation matches (on the first column),
-the others certainly will.
-
-You have to be careful, though; the example
-\begin{verbatim}
-f j ... = ...
--------------------
-f (a,b,c) ... = ...
-f d ... (e:f) = ...
-f (g,h,i) ... = ...
-\end{verbatim}
-{\em must} be broken into two blocks at the line shown; otherwise, you
-are forcing unnecessary evaluation. In any case, the top-left pattern
-always gives the cue. You could then unmix blocks into groups of...
-\begin{description}
-\item[all variables:]
-As it is now.
-\item[constructors or variables (mixed):]
-Need to make sure the right names get bound for the variable patterns.
-\item[literals or variables (mixed):]
-Presumably just a variant on the constructor case (as it is now).
-\end{description}
-
-************************************************************************
-* *
-* matchWrapper: a convenient way to call @match@ *
-* *
-************************************************************************
-\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
-
-Calls to @match@ often involve similar (non-trivial) work; that work
-is collected here, in @matchWrapper@. This function takes as
-arguments:
-\begin{itemize}
-\item
-Typechecked @Matches@ (of a function definition, or a case or lambda
-expression)---the main input;
-\item
-An error message to be inserted into any (runtime) pattern-matching
-failure messages.
-\end{itemize}
-
-As results, @matchWrapper@ produces:
-\begin{itemize}
-\item
-A list of variables (@Locals@) that the caller must ``promise'' to
-bind to appropriate values; and
-\item
-a @CoreExpr@, the desugared output (main result).
-\end{itemize}
-
-The main actions of @matchWrapper@ include:
-\begin{enumerate}
-\item
-Flatten the @[TypecheckedMatch]@ into a suitable list of
-@EquationInfo@s.
-\item
-Create as many new variables as there are patterns in a pattern-list
-(in any one of the @EquationInfo@s).
-\item
-Create a suitable ``if it fails'' expression---a call to @error@ using
-the error-string input; the {\em type} of this fail value can be found
-by examining one of the RHS expressions in one of the @EquationInfo@s.
-\item
-Call @match@ with all of this information!
-\end{enumerate}
--}
-
-matchWrapper
- :: HsMatchContext GhcRn -- ^ For shadowing warning messages
- -> Maybe (LHsExpr GhcTc) -- ^ Scrutinee. (Just scrut) for a case expr
- -- case scrut of { p1 -> e1 ... }
- -- (and in this case the MatchGroup will
- -- have all singleton patterns)
- -- Nothing for a function definition
- -- f p1 q1 = ... -- No "scrutinee"
- -- f p2 q2 = ... -- in this case
- -> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared
- -> DsM ([Id], CoreExpr) -- ^ Results (usually passed to 'match')
-
-{-
- There is one small problem with the Lambda Patterns, when somebody
- writes something similar to:
-\begin{verbatim}
- (\ (x:xs) -> ...)
-\end{verbatim}
- he/she don't want a warning about incomplete patterns, that is done with
- the flag @opt_WarnSimplePatterns@.
- This problem also appears in the:
-\begin{itemize}
-\item @do@ patterns, but if the @do@ can fail
- it creates another equation if the match can fail
- (see @DsExpr.doDo@ function)
-\item @let@ patterns, are treated by @matchSimply@
- List Comprension Patterns, are treated by @matchSimply@ also
-\end{itemize}
-
-We can't call @matchSimply@ with Lambda patterns,
-due to the fact that lambda patterns can have more than
-one pattern, and match simply only accepts one pattern.
-
-JJQC 30-Nov-1997
--}
-
-matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
- , mg_ext = MatchGroupTc arg_tys rhs_ty
- , mg_origin = origin })
- = do { dflags <- getDynFlags
- ; locn <- getSrcSpanDs
-
- ; new_vars <- case matches of
- [] -> mapM newSysLocalDsNoLP arg_tys
- (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
-
- ; eqns_info <- mapM (mk_eqn_info new_vars) matches
-
- -- Pattern match check warnings for /this match-group/
- ; when (isMatchContextPmChecked dflags origin ctxt) $
- addScrutTmCs mb_scr new_vars $
- -- See Note [Type and Term Equality Propagation]
- checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
-
- ; result_expr <- handleWarnings $
- matchEquations ctxt new_vars eqns_info rhs_ty
- ; return (new_vars, result_expr) }
- where
- -- Called once per equation in the match, or alternative in the case
- mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss }))
- = do { dflags <- getDynFlags
- ; let upats = map (unLoc . decideBangHood dflags) pats
- dicts = collectEvVarsPats upats
-
- ; match_result <-
- -- Extend the environment with knowledge about
- -- the matches before desugaring the RHS
- -- See Note [Type and Term Equality Propagation]
- applyWhen (needToRunPmCheck dflags origin)
- (addTyCsDs dicts . addScrutTmCs mb_scr vars . addPatTmCs upats vars)
- (dsGRHSs ctxt grhss rhs_ty)
-
- ; return (EqnInfo { eqn_pats = upats
- , eqn_orig = FromSource
- , eqn_rhs = match_result }) }
- mk_eqn_info _ (L _ (XMatch nec)) = noExtCon nec
-
- handleWarnings = if isGenerated origin
- then discardWarningsDs
- else id
-matchWrapper _ _ (XMatchGroup nec) = noExtCon nec
-
-matchEquations :: HsMatchContext GhcRn
- -> [MatchId] -> [EquationInfo] -> Type
- -> DsM CoreExpr
-matchEquations ctxt vars eqns_info rhs_ty
- = do { let error_doc = matchContextErrString ctxt
-
- ; match_result <- match vars rhs_ty eqns_info
-
- ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
- ; extractMatchResult match_result fail_expr }
-
-{-
-************************************************************************
-* *
-\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
-* *
-************************************************************************
-
-@mkSimpleMatch@ is a wrapper for @match@ which deals with the
-situation where we want to match a single expression against a single
-pattern. It returns an expression.
--}
-
-matchSimply :: CoreExpr -- ^ Scrutinee
- -> HsMatchContext GhcRn -- ^ Match kind
- -> LPat GhcTc -- ^ Pattern it should match
- -> CoreExpr -- ^ Return this if it matches
- -> CoreExpr -- ^ Return this if it doesn't
- -> DsM CoreExpr
--- Do not warn about incomplete patterns; see matchSinglePat comments
-matchSimply scrut hs_ctx pat result_expr fail_expr = do
- let
- match_result = cantFailMatchResult result_expr
- rhs_ty = exprType fail_expr
- -- Use exprType of fail_expr, because won't refine in the case of failure!
- match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
- extractMatchResult match_result' fail_expr
-
-matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc
- -> Type -> MatchResult -> DsM MatchResult
--- matchSinglePat ensures that the scrutinee is a variable
--- and then calls matchSinglePatVar
---
--- matchSinglePat does not warn about incomplete patterns
--- Used for things like [ e | pat <- stuff ], where
--- incomplete patterns are just fine
-
-matchSinglePat (Var var) ctx pat ty match_result
- | not (isExternalName (idName var))
- = matchSinglePatVar var ctx pat ty match_result
-
-matchSinglePat scrut hs_ctx pat ty match_result
- = do { var <- selectSimpleMatchVarL pat
- ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result
- ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
-
-matchSinglePatVar :: Id -- See Note [Match Ids]
- -> HsMatchContext GhcRn -> LPat GhcTc
- -> Type -> MatchResult -> DsM MatchResult
-matchSinglePatVar var ctx pat ty match_result
- = ASSERT2( isInternalName (idName var), ppr var )
- do { dflags <- getDynFlags
- ; locn <- getSrcSpanDs
-
- -- Pattern match check warnings
- ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
-
- ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
- , eqn_orig = FromSource
- , eqn_rhs = match_result }
- ; match [var] ty [eqn_info] }
-
-
-{-
-************************************************************************
-* *
- Pattern classification
-* *
-************************************************************************
--}
-
-data PatGroup
- = PgAny -- Immediate match: variables, wildcards,
- -- lazy patterns
- | PgCon DataCon -- Constructor patterns (incl list, tuple)
- | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
- | PgLit Literal -- Literal patterns
- | PgN Rational -- Overloaded numeric literals;
- -- see Note [Don't use Literal for PgN]
- | PgOverS FastString -- Overloaded string literals
- | PgNpK Integer -- n+k patterns
- | PgBang -- Bang patterns
- | PgCo Type -- Coercion patterns; the type is the type
- -- of the pattern *inside*
- | PgView (LHsExpr GhcTc) -- view pattern (e -> p):
- -- the LHsExpr is the expression e
- Type -- the Type is the type of p (equivalently, the result type of e)
- | PgOverloadedList
-
-{- Note [Don't use Literal for PgN]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Previously we had, as PatGroup constructors
-
- | ...
- | PgN Literal -- Overloaded literals
- | PgNpK Literal -- n+k patterns
- | ...
-
-But Literal is really supposed to represent an *unboxed* literal, like Int#.
-We were sticking the literal from, say, an overloaded numeric literal pattern
-into a LitInt constructor. This didn't really make sense; and we now have
-the invariant that value in a LitInt must be in the range of the target
-machine's Int# type, and an overloaded literal could meaningfully be larger.
-
-Solution: For pattern grouping purposes, just store the literal directly in
-the PgN constructor as a Rational if numeric, and add a PgOverStr constructor
-for overloaded strings.
--}
-
-groupEquations :: DynFlags -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
--- If the result is of form [g1, g2, g3],
--- (a) all the (pg,eq) pairs in g1 have the same pg
--- (b) none of the gi are empty
--- The ordering of equations is unchanged
-groupEquations dflags eqns
- = NEL.groupBy same_gp $ [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
- -- comprehension on NonEmpty
- where
- same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
- (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
-
--- TODO Make subGroup1 using a NonEmptyMap
-subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems
- -> m -- Map.empty
- -> (a -> m -> Maybe (NonEmpty EquationInfo)) -- Map.lookup
- -> (a -> NonEmpty EquationInfo -> m -> m) -- Map.insert
- -> [(a, EquationInfo)] -> [NonEmpty EquationInfo]
--- Input is a particular group. The result sub-groups the
--- equations by with particular constructor, literal etc they match.
--- Each sub-list in the result has the same PatGroup
--- See Note [Take care with pattern order]
--- Parameterized by map operations to allow different implementations
--- and constraints, eg. types without Ord instance.
-subGroup elems empty lookup insert group
- = fmap NEL.reverse $ elems $ foldl' accumulate empty group
- where
- accumulate pg_map (pg, eqn)
- = case lookup pg pg_map of
- Just eqns -> insert pg (NEL.cons eqn eqns) pg_map
- Nothing -> insert pg [eqn] pg_map
- -- pg_map :: Map a [EquationInfo]
- -- Equations seen so far in reverse order of appearance
-
-subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
-subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert
-
-subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
-subGroupUniq =
- subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)
-
-{- Note [Pattern synonym groups]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we see
- f (P a) = e1
- f (P b) = e2
- ...
-where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the
-same group? We can if P is a constructor, but /not/ if P is a pattern synonym.
-Consider (#11224)
- -- readMaybe :: Read a => String -> Maybe a
- pattern PRead :: Read a => () => a -> String
- pattern PRead a <- (readMaybe -> Just a)
-
- f (PRead (x::Int)) = e1
- f (PRead (y::Bool)) = e2
-This is all fine: we match the string by trying to read an Int; if that
-fails we try to read a Bool. But clearly we can't combine the two into a single
-match.
-
-Conclusion: we can combine when we invoke PRead /at the same type/. Hence
-in PgSyn we record the instantiating types, and use them in sameGroup.
-
-Note [Take care with pattern order]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In the subGroup function we must be very careful about pattern re-ordering,
-Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
-Then in bringing together the patterns for True, we must not
-swap the Nothing and y!
--}
-
-sameGroup :: PatGroup -> PatGroup -> Bool
--- Same group means that a single case expression
--- or test will suffice to match both, *and* the order
--- of testing within the group is insignificant.
-sameGroup PgAny PgAny = True
-sameGroup PgBang PgBang = True
-sameGroup (PgCon _) (PgCon _) = True -- One case expression
-sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
- -- eqTypes: See Note [Pattern synonym groups]
-sameGroup (PgLit _) (PgLit _) = True -- One case expression
-sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant
-sameGroup (PgOverS s1) (PgOverS s2) = s1==s2
-sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns]
-sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2
- -- CoPats are in the same goup only if the type of the
- -- enclosed pattern is the same. The patterns outside the CoPat
- -- always have the same type, so this boils down to saying that
- -- the two coercions are identical.
-sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
- -- ViewPats are in the same group iff the expressions
- -- are "equal"---conservatively, we use syntactic equality
-sameGroup _ _ = False
-
--- An approximation of syntactic equality used for determining when view
--- exprs are in the same group.
--- This function can always safely return false;
--- but doing so will result in the application of the view function being repeated.
---
--- Currently: compare applications of literals and variables
--- and anything else that we can do without involving other
--- HsSyn types in the recursion
---
--- NB we can't assume that the two view expressions have the same type. Consider
--- f (e1 -> True) = ...
--- f (e2 -> "hi") = ...
-viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool
-viewLExprEq (e1,_) (e2,_) = lexp e1 e2
- where
- lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
- lexp e e' = exp (unLoc e) (unLoc e')
-
- ---------
- exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
- -- real comparison is on HsExpr's
- -- strip parens
- exp (HsPar _ (L _ e)) e' = exp e e'
- exp e (HsPar _ (L _ e')) = exp e e'
- -- because the expressions do not necessarily have the same type,
- -- we have to compare the wrappers
- exp (XExpr (HsWrap h e)) (XExpr (HsWrap h' e')) = wrap h h' && exp e e'
- exp (HsVar _ i) (HsVar _ i') = i == i'
- exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
- -- the instance for IPName derives using the id, so this works if the
- -- above does
- exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
- exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'
- exp (HsOverLit _ l) (HsOverLit _ l') =
- -- Overloaded lits are equal if they have the same type
- -- and the data is the same.
- -- this is coarser than comparing the SyntaxExpr's in l and l',
- -- which resolve the overloading (e.g., fromInteger 1),
- -- because these expressions get written as a bunch of different variables
- -- (presumably to improve sharing)
- eqType (overLitType l) (overLitType l') && l == l'
- exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
- -- the fixities have been straightened out by now, so it's safe
- -- to ignore them?
- exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
- lexp l l' && lexp o o' && lexp ri ri'
- exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
- exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
- lexp e1 e1' && lexp e2 e2'
- exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
- lexp e1 e1' && lexp e2 e2'
- exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
- eq_list tup_arg es1 es2
- exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
- exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =
- lexp e e' && lexp e1 e1' && lexp e2 e2'
-
- -- Enhancement: could implement equality for more expressions
- -- if it seems useful
- -- But no need for HsLit, ExplicitList, ExplicitTuple,
- -- because they cannot be functions
- exp _ _ = False
-
- ---------
- syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
- syn_exp (SyntaxExprTc { syn_expr = expr1
- , syn_arg_wraps = arg_wraps1
- , syn_res_wrap = res_wrap1 })
- (SyntaxExprTc { syn_expr = expr2
- , syn_arg_wraps = arg_wraps2
- , syn_res_wrap = res_wrap2 })
- = exp expr1 expr2 &&
- and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&
- wrap res_wrap1 res_wrap2
- syn_exp NoSyntaxExprTc NoSyntaxExprTc = True
- syn_exp _ _ = False
-
- ---------
- tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
- tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
- tup_arg _ _ = False
-
- ---------
- wrap :: HsWrapper -> HsWrapper -> Bool
- -- Conservative, in that it demands that wrappers be
- -- syntactically identical and doesn't look under binders
- --
- -- Coarser notions of equality are possible
- -- (e.g., reassociating compositions,
- -- equating different ways of writing a coercion)
- wrap WpHole WpHole = True
- wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
- wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'
- wrap (WpCast co) (WpCast co') = co `eqCoercion` co'
- wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2
- wrap (WpTyApp t) (WpTyApp t') = eqType t t'
- -- Enhancement: could implement equality for more wrappers
- -- if it seems useful (lams and lets)
- wrap _ _ = False
-
- ---------
- ev_term :: EvTerm -> EvTerm -> Bool
- ev_term (EvExpr (Var a)) (EvExpr (Var b)) = a==b
- ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b
- ev_term _ _ = False
-
- ---------
- eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
- eq_list _ [] [] = True
- eq_list _ [] (_:_) = False
- eq_list _ (_:_) [] = False
- eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
-
-patGroup :: DynFlags -> Pat GhcTc -> PatGroup
-patGroup _ (ConPatOut { pat_con = L _ con
- , pat_arg_tys = tys })
- | RealDataCon dcon <- con = PgCon dcon
- | PatSynCon psyn <- con = PgSyn psyn tys
-patGroup _ (WildPat {}) = PgAny
-patGroup _ (BangPat {}) = PgBang
-patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =
- case (oval, isJust mb_neg) of
- (HsIntegral i, False) -> PgN (fromInteger (il_value i))
- (HsIntegral i, True ) -> PgN (-fromInteger (il_value i))
- (HsFractional r, False) -> PgN (fl_value r)
- (HsFractional r, True ) -> PgN (-fl_value r)
- (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
- PgOverS s
-patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
- case oval of
- HsIntegral i -> PgNpK (il_value i)
- _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
-patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p)
- -- Type of innelexp pattern
-patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p))
-patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList
-patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit)
-patGroup _ pat = pprPanic "patGroup" (ppr pat)
-
-{-
-Note [Grouping overloaded literal patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-WATCH OUT! Consider
-
- f (n+1) = ...
- f (n+2) = ...
- f (n+1) = ...
-
-We can't group the first and third together, because the second may match
-the same thing as the first. Same goes for *overloaded* literal patterns
- f 1 True = ...
- f 2 False = ...
- f 1 False = ...
-If the first arg matches '1' but the second does not match 'True', we
-cannot jump to the third equation! Because the same argument might
-match '2'!
-Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
--}
diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot
deleted file mode 100644
index 6d6cf989df..0000000000
--- a/compiler/deSugar/Match.hs-boot
+++ /dev/null
@@ -1,36 +0,0 @@
-module Match where
-
-import GhcPrelude
-import Var ( Id )
-import TcType ( Type )
-import DsMonad ( DsM, EquationInfo, MatchResult )
-import CoreSyn ( CoreExpr )
-import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr )
-import GHC.Hs.Extension ( GhcRn, GhcTc )
-
-match :: [Id]
- -> Type
- -> [EquationInfo]
- -> DsM MatchResult
-
-matchWrapper
- :: HsMatchContext GhcRn
- -> Maybe (LHsExpr GhcTc)
- -> MatchGroup GhcTc (LHsExpr GhcTc)
- -> DsM ([Id], CoreExpr)
-
-matchSimply
- :: CoreExpr
- -> HsMatchContext GhcRn
- -> LPat GhcTc
- -> CoreExpr
- -> CoreExpr
- -> DsM CoreExpr
-
-matchSinglePatVar
- :: Id
- -> HsMatchContext GhcRn
- -> LPat GhcTc
- -> Type
- -> MatchResult
- -> DsM MatchResult
diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs
deleted file mode 100644
index b5d5807592..0000000000
--- a/compiler/deSugar/MatchCon.hs
+++ /dev/null
@@ -1,296 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Pattern-matching constructors
--}
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module MatchCon ( matchConFamily, matchPatSyn ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import {-# SOURCE #-} Match ( match )
-
-import GHC.Hs
-import DsBinds
-import ConLike
-import BasicTypes ( Origin(..) )
-import TcType
-import DsMonad
-import DsUtils
-import MkCore ( mkCoreLets )
-import Util
-import Id
-import NameEnv
-import FieldLabel ( flSelector )
-import SrcLoc
-import Outputable
-import Control.Monad(liftM)
-import Data.List (groupBy)
-import Data.List.NonEmpty (NonEmpty(..))
-
-{-
-We are confronted with the first column of patterns in a set of
-equations, all beginning with constructors from one ``family'' (e.g.,
-@[]@ and @:@ make up the @List@ ``family''). We want to generate the
-alternatives for a @Case@ expression. There are several choices:
-\begin{enumerate}
-\item
-Generate an alternative for every constructor in the family, whether
-they are used in this set of equations or not; this is what the Wadler
-chapter does.
-\begin{description}
-\item[Advantages:]
-(a)~Simple. (b)~It may also be that large sparsely-used constructor
-families are mainly handled by the code for literals.
-\item[Disadvantages:]
-(a)~Not practical for large sparsely-used constructor families, e.g.,
-the ASCII character set. (b)~Have to look up a list of what
-constructors make up the whole family.
-\end{description}
-
-\item
-Generate an alternative for each constructor used, then add a default
-alternative in case some constructors in the family weren't used.
-\begin{description}
-\item[Advantages:]
-(a)~Alternatives aren't generated for unused constructors. (b)~The
-STG is quite happy with defaults. (c)~No lookup in an environment needed.
-\item[Disadvantages:]
-(a)~A spurious default alternative may be generated.
-\end{description}
-
-\item
-``Do it right:'' generate an alternative for each constructor used,
-and add a default alternative if all constructors in the family
-weren't used.
-\begin{description}
-\item[Advantages:]
-(a)~You will get cases with only one alternative (and no default),
-which should be amenable to optimisation. Tuples are a common example.
-\item[Disadvantages:]
-(b)~Have to look up constructor families in TDE (as above).
-\end{description}
-\end{enumerate}
-
-We are implementing the ``do-it-right'' option for now. The arguments
-to @matchConFamily@ are the same as to @match@; the extra @Int@
-returned is the number of constructors in the family.
-
-The function @matchConFamily@ is concerned with this
-have-we-used-all-the-constructors? question; the local function
-@match_cons_used@ does all the real work.
--}
-
-matchConFamily :: NonEmpty Id
- -> Type
- -> NonEmpty (NonEmpty EquationInfo)
- -> DsM MatchResult
--- Each group of eqns is for a single constructor
-matchConFamily (var :| vars) ty groups
- = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups
- return (mkCoAlgCaseMatchResult var ty alts)
- where
- toRealAlt alt = case alt_pat alt of
- RealDataCon dcon -> alt{ alt_pat = dcon }
- _ -> panic "matchConFamily: not RealDataCon"
-
-matchPatSyn :: NonEmpty Id
- -> Type
- -> NonEmpty EquationInfo
- -> DsM MatchResult
-matchPatSyn (var :| vars) ty eqns
- = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns
- return (mkCoSynCaseMatchResult var ty alt)
- where
- toSynAlt alt = case alt_pat alt of
- PatSynCon psyn -> alt{ alt_pat = psyn }
- _ -> panic "matchPatSyn: not PatSynCon"
-
-type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))
-
-matchOneConLike :: [Id]
- -> Type
- -> NonEmpty EquationInfo
- -> DsM (CaseAlt ConLike)
-matchOneConLike vars ty (eqn1 :| eqns) -- All eqns for a single constructor
- = do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )
- -- ex_tvs can only be tyvars as data types in source
- -- Haskell cannot mention covar yet (Aug 2018).
- ASSERT( tvs1 `equalLength` ex_tvs )
- arg_tys ++ mkTyVarTys tvs1
-
- val_arg_tys = conLikeInstOrigArgTys con1 inst_tys
- -- dataConInstOrigArgTys takes the univ and existential tyvars
- -- and returns the types of the *value* args, which is what we want
-
- match_group :: [Id]
- -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
- -- All members of the group have compatible ConArgPats
- match_group arg_vars arg_eqn_prs
- = ASSERT( notNull arg_eqn_prs )
- do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
- ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
- ; match_result <- match (group_arg_vars ++ vars) ty eqns'
- ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
-
- shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
- pat_binds = bind, pat_args = args
- } : pats }))
- = do ds_bind <- dsTcEvBinds bind
- return ( wrapBinds (tvs `zip` tvs1)
- . wrapBinds (ds `zip` dicts1)
- . mkCoreLets ds_bind
- , eqn { eqn_orig = Generated
- , eqn_pats = conArgPats val_arg_tys args ++ pats }
- )
- shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
-
- ; arg_vars <- selectConMatchVars val_arg_tys args1
- -- Use the first equation as a source of
- -- suggestions for the new variables
-
- -- Divide into sub-groups; see Note [Record patterns]
- ; let groups :: [[(ConArgPats, EquationInfo)]]
- groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn)
- | eqn <- eqn1:eqns ]
-
- ; match_results <- mapM (match_group arg_vars) groups
-
- ; return $ MkCaseAlt{ alt_pat = con1,
- alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,
- alt_wrapper = wrapper1,
- alt_result = foldr1 combineMatchResults match_results } }
- where
- ConPatOut { pat_con = L _ con1
- , pat_arg_tys = arg_tys, pat_wrap = wrapper1,
- pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
- = firstPat eqn1
- fields1 = map flSelector (conLikeFieldLabels con1)
-
- ex_tvs = conLikeExTyCoVars con1
-
- -- Choose the right arg_vars in the right order for this group
- -- Note [Record patterns]
- select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id]
- select_arg_vars arg_vars ((arg_pats, _) : _)
- | RecCon flds <- arg_pats
- , let rpats = rec_flds flds
- , not (null rpats) -- Treated specially; cf conArgPats
- = ASSERT2( fields1 `equalLength` arg_vars,
- ppr con1 $$ ppr fields1 $$ ppr arg_vars )
- map lookup_fld rpats
- | otherwise
- = arg_vars
- where
- fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
- lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
- (idName (unLoc (hsRecFieldId rpat)))
- select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
-
------------------
-compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool
--- Two constructors have compatible argument patterns if the number
--- and order of sub-matches is the same in both cases
-compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2
-compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1)
-compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2)
-compatible_pats _ _ = True -- Prefix or infix con
-
-same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc)
- -> Bool
-same_fields flds1 flds2
- = all2 (\(L _ f1) (L _ f2)
- -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
- (rec_flds flds1) (rec_flds flds2)
-
-
------------------
-selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]
-selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDsNoLP arg_tys
-selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps)
-selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]
-
-conArgPats :: [Type] -- Instantiated argument types
- -- Used only to fill in the types of WildPats, which
- -- are probably never looked at anyway
- -> ConArgPats
- -> [Pat GhcTc]
-conArgPats _arg_tys (PrefixCon ps) = map unLoc ps
-conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
-conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
- | null rpats = map WildPat arg_tys
- -- Important special case for C {}, which can be used for a
- -- datacon that isn't declared to have fields at all
- | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats
-
-{-
-Note [Record patterns]
-~~~~~~~~~~~~~~~~~~~~~~
-Consider
- data T = T { x,y,z :: Bool }
-
- f (T { y=True, x=False }) = ...
-
-We must match the patterns IN THE ORDER GIVEN, thus for the first
-one we match y=True before x=False. See #246; or imagine
-matching against (T { y=False, x=undefined }): should fail without
-touching the undefined.
-
-Now consider:
-
- f (T { y=True, x=False }) = ...
- f (T { x=True, y= False}) = ...
-
-In the first we must test y first; in the second we must test x
-first. So we must divide even the equations for a single constructor
-T into sub-groups, based on whether they match the same field in the
-same order. That's what the (groupBy compatible_pats) grouping.
-
-All non-record patterns are "compatible" in this sense, because the
-positional patterns (T a b) and (a `T` b) all match the arguments
-in order. Also T {} is special because it's equivalent to (T _ _).
-Hence the (null rpats) checks here and there.
-
-
-Note [Existentials in shift_con_pat]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- data T = forall a. Ord a => T a (a->Int)
-
- f (T x f) True = ...expr1...
- f (T y g) False = ...expr2..
-
-When we put in the tyvars etc we get
-
- f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1...
- f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2...
-
-After desugaring etc we'll get a single case:
-
- f = \t::T b::Bool ->
- case t of
- T a (d::Ord a) (x::a) (f::a->Int)) ->
- case b of
- True -> ...expr1...
- False -> ...expr2...
-
-*** We have to substitute [a/b, d/e] in expr2! **
-Hence
- False -> ....((/\b\(e:Ord b).expr2) a d)....
-
-Originally I tried to use
- (\b -> let e = d in expr2) a
-to do this substitution. While this is "correct" in a way, it fails
-Lint, because e::Ord b but d::Ord a.
-
--}
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
deleted file mode 100644
index a6ec151bfd..0000000000
--- a/compiler/deSugar/MatchLit.hs
+++ /dev/null
@@ -1,520 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Pattern-matching literal patterns
--}
-
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module MatchLit ( dsLit, dsOverLit, hsLitKey
- , tidyLitPat, tidyNPat
- , matchLiterals, matchNPlusKPats, matchNPats
- , warnAboutIdentities
- , warnAboutOverflowedOverLit, warnAboutOverflowedLit
- , warnAboutEmptyEnumerations
- ) where
-
-#include "HsVersions.h"
-
-import GhcPrelude
-
-import {-# SOURCE #-} Match ( match )
-import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr )
-
-import DsMonad
-import DsUtils
-
-import GHC.Hs
-
-import Id
-import CoreSyn
-import MkCore
-import TyCon
-import DataCon
-import TcHsSyn ( shortCutLit )
-import TcType
-import Name
-import Type
-import PrelNames
-import TysWiredIn
-import TysPrim
-import Literal
-import SrcLoc
-import Data.Ratio
-import Outputable
-import BasicTypes
-import DynFlags
-import Util
-import FastString
-import qualified GHC.LanguageExtensions as LangExt
-
-import Control.Monad
-import Data.Int
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NEL
-import Data.Word
-import Data.Proxy
-
-{-
-************************************************************************
-* *
- Desugaring literals
- [used to be in DsExpr, but DsMeta needs it,
- and it's nice to avoid a loop]
-* *
-************************************************************************
-
-We give int/float literals type @Integer@ and @Rational@, respectively.
-The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
-around them.
-
-ToDo: put in range checks for when converting ``@i@''
-(or should that be in the typechecker?)
-
-For numeric literals, we try to detect there use at a standard type
-(@Int@, @Float@, etc.) are directly put in the right constructor.
-[NB: down with the @App@ conversion.]
-
-See also below where we look for @DictApps@ for \tr{plusInt}, etc.
--}
-
-dsLit :: HsLit GhcRn -> DsM CoreExpr
-dsLit l = do
- dflags <- getDynFlags
- case l of
- HsStringPrim _ s -> return (Lit (LitString s))
- HsCharPrim _ c -> return (Lit (LitChar c))
- HsIntPrim _ i -> return (Lit (mkLitIntWrap dflags i))
- HsWordPrim _ w -> return (Lit (mkLitWordWrap dflags w))
- HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap dflags i))
- HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w))
- HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f)))
- HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))
- HsChar _ c -> return (mkCharExpr c)
- HsString _ str -> mkStringExprFS str
- HsInteger _ i _ -> mkIntegerExpr i
- HsInt _ i -> return (mkIntExpr dflags (il_value i))
- XLit nec -> noExtCon nec
- HsRat _ (FL _ _ val) ty -> do
- num <- mkIntegerExpr (numerator val)
- denom <- mkIntegerExpr (denominator val)
- return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
- where
- (ratio_data_con, integer_ty)
- = case tcSplitTyConApp ty of
- (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
- (head (tyConDataCons tycon), i_ty)
- x -> pprPanic "dsLit" (ppr x)
-
-dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
--- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains
--- (an expression for) the literal value itself.
-dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
- , ol_witness = witness }) = do
- dflags <- getDynFlags
- case shortCutLit dflags val ty of
- Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut]
- _ -> dsExpr witness
-dsOverLit (XOverLit nec) = noExtCon nec
-{-
-Note [Literal short cut]
-~~~~~~~~~~~~~~~~~~~~~~~~
-The type checker tries to do this short-cutting as early as possible, but
-because of unification etc, more information is available to the desugarer.
-And where it's possible to generate the correct literal right away, it's
-much better to do so.
-
-
-************************************************************************
-* *
- Warnings about overflowed literals
-* *
-************************************************************************
-
-Warn about functions like toInteger, fromIntegral, that convert
-between one type and another when the to- and from- types are the
-same. Then it's probably (albeit not definitely) the identity
--}
-
-warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
-warnAboutIdentities dflags (Var conv_fn) type_of_conv
- | wopt Opt_WarnIdentities dflags
- , idName conv_fn `elem` conversionNames
- , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
- , arg_ty `eqType` res_ty -- So we are converting ty -> ty
- = warnDs (Reason Opt_WarnIdentities)
- (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
- , nest 2 $ text "can probably be omitted"
- ])
-warnAboutIdentities _ _ _ = return ()
-
-conversionNames :: [Name]
-conversionNames
- = [ toIntegerName, toRationalName
- , fromIntegralName, realToFracName ]
- -- We can't easily add fromIntegerName, fromRationalName,
- -- because they are generated by literals
-
-
--- | Emit warnings on overloaded integral literals which overflow the bounds
--- implied by their type.
-warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
-warnAboutOverflowedOverLit hsOverLit = do
- dflags <- getDynFlags
- warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit)
-
--- | Emit warnings on integral literals which overflow the bounds implied by
--- their type.
-warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
-warnAboutOverflowedLit hsLit = do
- dflags <- getDynFlags
- warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit)
-
--- | Emit warnings on integral literals which overflow the bounds implied by
--- their type.
-warnAboutOverflowedLiterals
- :: DynFlags
- -> Maybe (Integer, Name) -- ^ the literal value and name of its tycon
- -> DsM ()
-warnAboutOverflowedLiterals dflags lit
- | wopt Opt_WarnOverflowedLiterals dflags
- , Just (i, tc) <- lit
- = if tc == intTyConName then check i tc (Proxy :: Proxy Int)
-
- -- These only show up via the 'HsOverLit' route
- else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8)
- else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16)
- else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32)
- else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64)
- else if tc == wordTyConName then check i tc (Proxy :: Proxy Word)
- else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8)
- else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16)
- else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32)
- else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64)
- else if tc == naturalTyConName then checkPositive i tc
-
- -- These only show up via the 'HsLit' route
- else if tc == intPrimTyConName then check i tc (Proxy :: Proxy Int)
- else if tc == int8PrimTyConName then check i tc (Proxy :: Proxy Int8)
- else if tc == int32PrimTyConName then check i tc (Proxy :: Proxy Int32)
- else if tc == int64PrimTyConName then check i tc (Proxy :: Proxy Int64)
- else if tc == wordPrimTyConName then check i tc (Proxy :: Proxy Word)
- else if tc == word8PrimTyConName then check i tc (Proxy :: Proxy Word8)
- else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32)
- else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64)
-
- else return ()
-
- | otherwise = return ()
- where
-
- checkPositive :: Integer -> Name -> DsM ()
- checkPositive i tc
- = when (i < 0) $ do
- warnDs (Reason Opt_WarnOverflowedLiterals)
- (vcat [ text "Literal" <+> integer i
- <+> text "is negative but" <+> ppr tc
- <+> ptext (sLit "only supports positive numbers")
- ])
-
- check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
- check i tc _proxy
- = when (i < minB || i > maxB) $ do
- warnDs (Reason Opt_WarnOverflowedLiterals)
- (vcat [ text "Literal" <+> integer i
- <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")
- <+> integer minB <> text ".." <> integer maxB
- , sug ])
- where
- minB = toInteger (minBound :: a)
- maxB = toInteger (maxBound :: a)
- sug | minB == -i -- Note [Suggest NegativeLiterals]
- , i > 0
- , not (xopt LangExt.NegativeLiterals dflags)
- = text "If you are trying to write a large negative literal, use NegativeLiterals"
- | otherwise = Outputable.empty
-
-{-
-Note [Suggest NegativeLiterals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If you write
- x :: Int8
- x = -128
-it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals.
-We get an erroneous suggestion for
- x = 128
-but perhaps that does not matter too much.
--}
-
-warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
- -> LHsExpr GhcTc -> DsM ()
--- ^ Warns about @[2,3 .. 1]@ which returns the empty list.
--- Only works for integral types, not floating point.
-warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
- | wopt Opt_WarnEmptyEnumerations dflags
- , Just (from,tc) <- getLHsIntegralLit fromExpr
- , Just mThn <- traverse getLHsIntegralLit mThnExpr
- , Just (to,_) <- getLHsIntegralLit toExpr
- , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM ()
- check _proxy
- = when (null enumeration) $
- warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")
- where
- enumeration :: [a]
- enumeration = case mThn of
- Nothing -> [fromInteger from .. fromInteger to]
- Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to]
-
- = if tc == intTyConName then check (Proxy :: Proxy Int)
- else if tc == int8TyConName then check (Proxy :: Proxy Int8)
- else if tc == int16TyConName then check (Proxy :: Proxy Int16)
- else if tc == int32TyConName then check (Proxy :: Proxy Int32)
- else if tc == int64TyConName then check (Proxy :: Proxy Int64)
- else if tc == wordTyConName then check (Proxy :: Proxy Word)
- else if tc == word8TyConName then check (Proxy :: Proxy Word8)
- else if tc == word16TyConName then check (Proxy :: Proxy Word16)
- else if tc == word32TyConName then check (Proxy :: Proxy Word32)
- else if tc == word64TyConName then check (Proxy :: Proxy Word64)
- else if tc == integerTyConName then check (Proxy :: Proxy Integer)
- else if tc == naturalTyConName then check (Proxy :: Proxy Integer)
- -- We use 'Integer' because otherwise a negative 'Natural' literal
- -- could cause a compile time crash (instead of a runtime one).
- -- See the T10930b test case for an example of where this matters.
- else return ()
-
- | otherwise = return ()
-
-getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
--- ^ See if the expression is an 'Integral' literal.
--- Remember to look through automatically-added tick-boxes! (#8384)
-getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
-getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit
-getLHsIntegralLit _ = Nothing
-
--- | If 'Integral', extract the value and type name of the overloaded literal.
-getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
-getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
- | Just tc <- tyConAppTyCon_maybe ty
- = Just (il_value i, tyConName tc)
-getIntegralLit _ = Nothing
-
--- | If 'Integral', extract the value and type name of the non-overloaded
--- literal.
-getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name)
-getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName)
-getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName)
-getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName)
-getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName)
-getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName)
-getSimpleIntegralLit (HsInteger _ i ty)
- | Just tc <- tyConAppTyCon_maybe ty
- = Just (i, tyConName tc)
-getSimpleIntegralLit _ = Nothing
-
-{-
-************************************************************************
-* *
- Tidying lit pats
-* *
-************************************************************************
--}
-
-tidyLitPat :: HsLit GhcTc -> Pat GhcTc
--- Result has only the following HsLits:
--- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
--- HsDoublePrim, HsStringPrim, HsString
--- * HsInteger, HsRat, HsInt can't show up in LitPats
--- * We get rid of HsChar right here
-tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
-tidyLitPat (HsString src s)
- | lengthFS s <= 1 -- Short string literals only
- = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
- [mkCharLitPat src c, pat] [charTy])
- (mkNilPat charTy) (unpackFS s)
- -- The stringTy is the type of the whole pattern, not
- -- the type to instantiate (:) or [] with!
-tidyLitPat lit = LitPat noExtField lit
-
-----------------
-tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
- -> Type
- -> Pat GhcTc
-tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
- -- False: Take short cuts only if the literal is not using rebindable syntax
- --
- -- Once that is settled, look for cases where the type of the
- -- entire overloaded literal matches the type of the underlying literal,
- -- and in that case take the short cut
- -- NB: Watch out for weird cases like #3382
- -- f :: Int -> Int
- -- f "blah" = 4
- -- which might be ok if we have 'instance IsString Int'
- --
- | not type_change, isIntTy ty, Just int_lit <- mb_int_lit
- = mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit)
- | not type_change, isWordTy ty, Just int_lit <- mb_int_lit
- = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit)
- | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
- = tidyLitPat (HsString NoSourceText str_lit)
- -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
- -- If we do convert to the constructor form, we'll generate a case
- -- expression on a Float# or Double# and that's not allowed in Core; see
- -- #9238 and Note [Rules for floating-point comparisons] in PrelRules
- where
- -- Sometimes (like in test case
- -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include
- -- type-changing wrappers (for example, from Id Int to Int, for the identity
- -- type family Id). In these cases, we can't do the short-cut.
- type_change = not (outer_ty `eqType` ty)
-
- mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
- mk_con_pat con lit
- = unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] [])
-
- mb_int_lit :: Maybe Integer
- mb_int_lit = case (mb_neg, val) of
- (Nothing, HsIntegral i) -> Just (il_value i)
- (Just _, HsIntegral i) -> Just (-(il_value i))
- _ -> Nothing
-
- mb_str_lit :: Maybe FastString
- mb_str_lit = case (mb_neg, val) of
- (Nothing, HsIsString _ s) -> Just s
- _ -> Nothing
-
-tidyNPat over_lit mb_neg eq outer_ty
- = NPat outer_ty (noLoc over_lit) mb_neg eq
-
-{-
-************************************************************************
-* *
- Pattern matching on LitPat
-* *
-************************************************************************
--}
-
-matchLiterals :: NonEmpty Id
- -> Type -- ^ Type of the whole case expression
- -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
- -> DsM MatchResult
-
-matchLiterals (var :| vars) ty sub_groups
- = do { -- Deal with each group
- ; alts <- mapM match_group sub_groups
-
- -- Combine results. For everything except String
- -- we can use a case expression; for String we need
- -- a chain of if-then-else
- ; if isStringTy (idType var) then
- do { eq_str <- dsLookupGlobalId eqStringName
- ; mrs <- mapM (wrap_str_guard eq_str) alts
- ; return (foldr1 combineMatchResults mrs) }
- else
- return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
- }
- where
- match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult)
- match_group eqns@(firstEqn :| _)
- = do { dflags <- getDynFlags
- ; let LitPat _ hs_lit = firstPat firstEqn
- ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
- ; return (hsLitKey dflags hs_lit, match_result) }
-
- wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
- -- Equality check for string literals
- wrap_str_guard eq_str (LitString s, mr)
- = do { -- We now have to convert back to FastString. Perhaps there
- -- should be separate LitBytes and LitString constructors?
- let s' = mkFastStringByteString s
- ; lit <- mkStringExprFS s'
- ; let pred = mkApps (Var eq_str) [Var var, lit]
- ; return (mkGuardedMatchResult pred mr) }
- wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
-
-
----------------------------
-hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
--- Get the Core literal corresponding to a HsLit.
--- It only works for primitive types and strings;
--- others have been removed by tidy
--- For HsString, it produces a LitString, which really represents an _unboxed_
--- string literal; and we deal with it in matchLiterals above. Otherwise, it
--- produces a primitive Literal of type matching the original HsLit.
--- In the case of the fixed-width numeric types, we need to wrap here
--- because Literal has an invariant that the literal is in range, while
--- HsLit does not.
-hsLitKey dflags (HsIntPrim _ i) = mkLitIntWrap dflags i
-hsLitKey dflags (HsWordPrim _ w) = mkLitWordWrap dflags w
-hsLitKey dflags (HsInt64Prim _ i) = mkLitInt64Wrap dflags i
-hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w
-hsLitKey _ (HsCharPrim _ c) = mkLitChar c
-hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f)
-hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d)
-hsLitKey _ (HsString _ s) = LitString (bytesFS s)
-hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
-
-{-
-************************************************************************
-* *
- Pattern matching on NPat
-* *
-************************************************************************
--}
-
-matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult
-matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal
- = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
- ; lit_expr <- dsOverLit lit
- ; neg_lit <- case mb_neg of
- Nothing -> return lit_expr
- Just neg -> dsSyntaxExpr neg [lit_expr]
- ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
- ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
- ; return (mkGuardedMatchResult pred_expr match_result) }
-
-{-
-************************************************************************
-* *
- Pattern matching on n+k patterns
-* *
-************************************************************************
-
-For an n+k pattern, we use the various magic expressions we've been given.
-We generate:
-\begin{verbatim}
- if ge var lit then
- let n = sub var lit
- in <expr-for-a-successful-match>
- else
- <try-next-pattern-or-whatever>
-\end{verbatim}
--}
-
-matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult
--- All NPlusKPats, for the *same* literal k
-matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
- = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
- = firstPat eqn1
- ; lit1_expr <- dsOverLit lit1
- ; lit2_expr <- dsOverLit lit2
- ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr]
- ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
- ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
- ; match_result <- match vars ty eqns'
- ; return (mkGuardedMatchResult pred_expr $
- mkCoLetMatchResult (NonRec n1 minusk_expr) $
- adjustMatchResult (foldr1 (.) wraps) $
- match_result) }
- where
- shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
- = (wrapBind n n1, eqn { eqn_pats = pats })
- -- The wrapBind is a no-op for the first equation
- shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
View Lorry Controller Status