Commit 8e6ec0fa authored by Alan Zimmerman's avatar Alan Zimmerman

Udate hsSyn AST to use Trees that Grow

Summary:
See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow

This commit prepares the ground for a full extensible AST, by replacing the type
parameter for the hsSyn data types with a set of indices into type families,

    data GhcPs -- ^ Index for GHC parser output
    data GhcRn -- ^ Index for GHC renamer output
    data GhcTc -- ^ Index for GHC typechecker output

These are now used instead of `RdrName`, `Name` and `Id`/`TcId`/`Var`

Where the original name type is required in a polymorphic context, this is
accessible via the IdP type family, defined as

    type family IdP p
    type instance IdP GhcPs = RdrName
    type instance IdP GhcRn = Name
    type instance IdP GhcTc = Id

These types are declared in the new 'hsSyn/HsExtension.hs' module.

To gain a better understanding of the extension mechanism, it has been applied
to `HsLit` only, also replacing the `SourceText` fields in them with extension
types.

To preserve extension generality, a type class is introduced to capture the
`SourceText` interface, which must be honoured by all of the extension points
which originally had a `SourceText`.  The class is defined as

    class HasSourceText a where
      -- Provide setters to mimic existing constructors
      noSourceText  :: a
      sourceText    :: String -> a

      setSourceText :: SourceText -> a
      getSourceText :: a -> SourceText

And the constraint is captured in `SourceTextX`, which is a constraint type
listing all the extension points that make use of the class.

Updating Haddock submodule to match.

Test Plan: ./validate

Reviewers: simonpj, shayan-najd, goldfire, austin, bgamari

Subscribers: rwbarton, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D3609
parent c9eb4385
......@@ -18,7 +18,6 @@ module BkpSyn (
) where
import HsSyn
import RdrName
import SrcLoc
import Outputable
import Module
......@@ -61,7 +60,7 @@ type LHsUnit n = Located (HsUnit n)
-- or an include.
data HsDeclType = ModuleD | SignatureD
data HsUnitDecl n
= DeclD HsDeclType (Located ModuleName) (Maybe (Located (HsModule RdrName)))
= DeclD HsDeclType (Located ModuleName) (Maybe (Located (HsModule GhcPs)))
| IncludeD (IncludeDecl n)
type LHsUnitDecl n = Located (HsUnitDecl n)
......
......@@ -709,7 +709,7 @@ summariseRequirement pn mod_name = do
summariseDecl :: PackageName
-> HscSource
-> Located ModuleName
-> Maybe (Located (HsModule RdrName))
-> Maybe (Located (HsModule GhcPs))
-> BkpM ModSummary
summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
......@@ -736,7 +736,7 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
hsModuleToModSummary :: PackageName
-> HscSource
-> ModuleName
-> Located (HsModule RdrName)
-> Located (HsModule GhcPs)
-> BkpM ModSummary
hsModuleToModSummary pn hsc_src modname
hsmod = do
......
This diff is collapsed.
This diff is collapsed.
......@@ -7,6 +7,7 @@ The Desugarer: turning HsSyn into Core.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module Desugar (
-- * Desugaring operations
......@@ -250,7 +251,7 @@ So we pull out the type/coercion variables (which are in dependency order),
and Rec the rest.
-}
deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)
deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)
deSugarExpr hsc_env tc_expr = do {
let dflags = hsc_dflags hsc_env
......@@ -362,7 +363,7 @@ Reason
************************************************************************
-}
dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
= putSrcSpanDs loc $
do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
......@@ -541,7 +542,7 @@ subsequent transformations could fire.
************************************************************************
-}
dsVect :: LVectDecl Id -> DsM CoreVect
dsVect :: LVectDecl GhcTc -> DsM CoreVect
dsVect (L loc (HsVect _ (L _ v) rhs))
= putSrcSpanDs loc $
do { rhs' <- dsLExpr rhs
......
This diff is collapsed.
......@@ -11,6 +11,7 @@ lower levels it is preserved with @let@/@letrec@s).
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
......@@ -73,7 +74,7 @@ import Control.Monad
-- | Desugar top level binds, strict binds are treated like normal
-- binds since there is no good time to force before first usage.
dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds binds
-- see Note [Strict binds checks]
| not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
......@@ -102,7 +103,7 @@ dsTopLHsBinds binds
-- | 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 Id -> DsM ([Id], [(Id,CoreExpr)])
dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
dsLHsBinds binds
= do { MASSERT( allBag (not . isUnliftedHsBind . unLoc) binds )
; ds_bs <- mapBagM dsLHsBind binds
......@@ -110,14 +111,14 @@ dsLHsBinds binds
id ([], []) ds_bs) }
------------------------
dsLHsBind :: LHsBind Id
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 Id
-> 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
......@@ -275,7 +276,7 @@ dsHsBind dflags
,(poly_tup_id, poly_tup_rhs) :
concat export_binds_s) }
where
inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
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
......@@ -302,7 +303,7 @@ dsHsBind dflags
[] lcls
-- find exports or make up new exports for force variables
get_exports :: [Id] -> DsM ([Id], [ABExport Id])
get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])
get_exports lcls =
foldM (\(glbls, exports) lcl ->
case lookupVarEnv global_env lcl of
......@@ -373,7 +374,8 @@ dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
-- the unfolding in the interface file is made in `TidyPgm.addExternal`
-- using this information.
------------------------
makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
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
= (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
......
......@@ -7,6 +7,7 @@ Desugaring exporessions.
-}
{-# LANGUAGE CPP, MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
, dsValBinds, dsLit, dsSyntaxExpr ) where
......@@ -66,7 +67,7 @@ import Control.Monad
************************************************************************
-}
dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (L _ EmptyLocalBinds) body = return body
dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $
dsValBinds binds body
......@@ -74,12 +75,12 @@ dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body
-------------------------
-- caller sets location
dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn"
-------------------------
dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds (IPBinds ip_binds ev_binds) body
= do { ds_binds <- dsTcEvBinds ev_binds
; let inner = mkCoreLets ds_binds body
......@@ -93,7 +94,7 @@ dsIPBinds (IPBinds ip_binds ev_binds) body
-------------------------
-- caller sets location
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
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.
......@@ -173,7 +174,7 @@ ds_val_bind (is_rec, binds) body
-- only have to deal with lifted ones now; so Rec is ok
------------------
dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_exports = exports
, abs_ev_binds = ev_binds
......@@ -228,7 +229,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
************************************************************************
-}
dsLExpr :: LHsExpr Id -> DsM CoreExpr
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (L loc e)
= putSrcSpanDs loc $
......@@ -244,19 +245,19 @@ dsLExpr (L loc e)
-- be an argument to some other function.
-- See Note [Levity polymorphism checking] in DsMonad
-- See Note [Levity polymorphism invariants] in CoreSyn
dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr
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 Id -> DsM CoreExpr
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr = ds_expr False
ds_expr :: Bool -- are we directly inside an HsWrap?
-- See Wrinkle in Note [Detecting forced eta expansion]
-> HsExpr Id -> DsM CoreExpr
-> HsExpr GhcTc -> DsM CoreExpr
ds_expr _ (HsPar e) = dsLExpr e
ds_expr _ (ExprWithTySigOut e _) = dsLExpr e
ds_expr w (HsVar (L _ var)) = dsHsVar w var
......@@ -264,7 +265,7 @@ ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker e
ds_expr w (HsConLikeOut con) = dsConLike w con
ds_expr _ (HsIPVar _) = panic "dsExpr: HsIPVar"
ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel"
ds_expr _ (HsLit lit) = dsLit lit
ds_expr _ (HsLit lit) = dsLit (convertLit lit)
ds_expr _ (HsOverLit lit) = dsOverLit lit
ds_expr _ (HsWrap co_fn e)
......@@ -632,7 +633,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
; return (add_field_binds field_binds' $
bindNonRec discrim_var record_expr' matching_code) }
where
ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr)
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
......@@ -768,7 +769,7 @@ ds_expr _ (HsDo {}) = panic "dsExpr:HsDo"
ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"
------------------------------
dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (SyntaxExpr { syn_expr = expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap })
......@@ -782,7 +783,7 @@ dsSyntaxExpr (SyntaxExpr { syn_expr = expr
where
mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
findField :: [LHsRecField Id arg] -> Name -> [arg]
findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField rbinds sel
= [hsRecFieldArg fld | L _ fld <- rbinds
, sel == idName (unLoc $ hsRecFieldId fld) ]
......@@ -847,7 +848,7 @@ time.
maxBuildLength :: Int
maxBuildLength = 32
dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc]
-> DsM CoreExpr
-- See Note [Desugaring explicit lists]
dsExplicitList elt_ty Nothing xs
......@@ -871,7 +872,7 @@ dsExplicitList elt_ty (Just fln) xs
; dflags <- getDynFlags
; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr
dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
dsArithSeq expr (From from)
= App <$> dsExpr expr <*> dsLExprNoLP from
dsArithSeq expr (FromTo from to)
......@@ -898,7 +899,7 @@ handled in DsListComp). Basically does the translation given in the
Haskell 98 report:
-}
dsDo :: [ExprLStmt Id] -> DsM CoreExpr
dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo stmts
= goL stmts
where
......@@ -994,7 +995,7 @@ dsDo stmts
go _ (ParStmt {}) _ = panic "dsDo ParStmt"
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
handle_failure pat match fail_op
......@@ -1052,7 +1053,7 @@ dsConLike _ (PatSynCon ps) = return $ case patSynBuilder ps of
-}
-- Warn about certain types of values discarded in monadic bindings (#3263)
warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
warnDiscardedDoBindings rhs rhs_ty
| Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
= do { warn_unused <- woptM Opt_WarnUnusedDoBind
......@@ -1080,7 +1081,7 @@ warnDiscardedDoBindings rhs rhs_ty
| otherwise -- RHS does have type of form (m ty), which is weird
= return () -- but at lesat this warning is irrelevant
badMonadBind :: LHsExpr Id -> Type -> SDoc
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))
......@@ -1143,7 +1144,7 @@ we're not directly in an HsWrap, reject.
-- | 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 Id -> Type -> DsM ()
checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
checkForcedEtaExpansion expr ty
| Just var <- case expr of
HsVar (L _ var) -> Just var
......
module DsExpr where
import HsSyn ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )
import Var ( Id )
import DsMonad ( DsM )
import CoreSyn ( CoreExpr )
import HsSyn ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )
import DsMonad ( DsM )
import CoreSyn ( CoreExpr )
import HsExtension ( GhcTc)
dsExpr :: HsExpr Id -> DsM CoreExpr
dsLExpr, dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
......@@ -7,6 +7,8 @@ Desugaring foreign declarations (see also DsCCall).
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module DsForeign ( dsForeigns ) where
......@@ -69,14 +71,14 @@ is the same as
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
type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
-- the occurrence analyser will sort it all out
dsForeigns :: [LForeignDecl Id]
dsForeigns :: [LForeignDecl GhcTc]
-> DsM (ForeignStubs, OrdList Binding)
dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)
dsForeigns' :: [LForeignDecl Id]
dsForeigns' :: [LForeignDecl GhcTc]
-> DsM (ForeignStubs, OrdList Binding)
dsForeigns' []
= return (NoStubs, nilOL)
......
......@@ -18,7 +18,6 @@ import {-# SOURCE #-} Match ( matchSinglePat )
import HsSyn
import MkCore
import CoreSyn
import Var
import DsMonad
import DsUtils
......@@ -44,7 +43,7 @@ producing an expression with a runtime error in the corner if
necessary. The type argument gives the type of the @ei@.
-}
dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr
dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
dsGuarded grhss rhs_ty = do
match_result <- dsGRHSs PatBindRhs grhss rhs_ty
......@@ -54,7 +53,7 @@ dsGuarded grhss rhs_ty = do
-- In contrast, @dsGRHSs@ produces a @MatchResult@.
dsGRHSs :: HsMatchContext Name
-> GRHSs Id (LHsExpr Id) -- Guarded RHSs
-> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs
-> Type -- Type of RHS
-> DsM MatchResult
dsGRHSs hs_ctx (GRHSs grhss binds) rhs_ty
......@@ -65,7 +64,8 @@ dsGRHSs hs_ctx (GRHSs grhss binds) rhs_ty
-- NB: nested dsLet inside matchResult
; return match_result2 }
dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult
dsGRHS :: HsMatchContext Name -> 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
......@@ -77,10 +77,10 @@ dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
************************************************************************
-}
matchGuards :: [GuardStmt Id] -- Guard
-> HsStmtContext Name -- Context
-> LHsExpr Id -- RHS
-> Type -- Type of RHS of guard
matchGuards :: [GuardStmt GhcTc] -- Guard
-> HsStmtContext Name -- Context
-> LHsExpr GhcTc -- RHS
-> Type -- Type of RHS of guard
-> DsM MatchResult
-- See comments with HsExpr.Stmt re what a BodyStmt means
......@@ -126,7 +126,7 @@ matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
matchGuards (ApplicativeStmt {} : _) _ _ _ =
panic "matchGuards ApplicativeLastStmt"
isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr)
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-- Returns Just {..} if we're sure that the expression is True
-- I.e. * 'True' datacon
......
......@@ -7,6 +7,7 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions
-}
{-# LANGUAGE CPP, NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
......@@ -43,7 +44,7 @@ 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 Id]
dsListComp :: [ExprLStmt GhcTc]
-> Type -- Type of entire list
-> DsM CoreExpr
dsListComp lquals res_ty = do
......@@ -78,7 +79,7 @@ dsListComp lquals res_ty = do
-- 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 Id Id) -> DsM (CoreExpr, Type)
dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
dsInnerListComp (ParStmtBlock stmts bndrs _)
= do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
list_ty = mkListTy bndrs_tuple_type
......@@ -91,7 +92,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _)
-- 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 Id -> DsM (CoreExpr, LPat Id)
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
......@@ -211,7 +212,7 @@ The introduced tuples are Boxed, but only because I couldn't get it to work
with the Unboxed variety.
-}
deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr
deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr
deListComp [] _ = panic "deListComp"
......@@ -261,9 +262,9 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
deListComp (ApplicativeStmt {} : _) _ =
panic "deListComp ApplicativeStmt"
deBindComp :: OutPat Id
deBindComp :: OutPat GhcTc
-> CoreExpr
-> [ExprStmt Id]
-> [ExprStmt GhcTc]
-> CoreExpr
-> DsM (Expr Id)
deBindComp pat core_list1 quals core_list2 = do
......@@ -317,8 +318,8 @@ TE[ e | p <- l , q ] c n = let
\end{verbatim}
-}
dfListComp :: Id -> Id -- 'c' and 'n'
-> [ExprStmt Id] -- the rest of the qual's
dfListComp :: Id -> Id -- 'c' and 'n'
-> [ExprStmt GhcTc] -- the rest of the qual's
-> DsM CoreExpr
dfListComp _ _ [] = panic "dfListComp"
......@@ -356,9 +357,9 @@ dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
dfListComp _ _ (ApplicativeStmt {} : _) =
panic "dfListComp ApplicativeStmt"
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat Id, CoreExpr)
-> [ExprStmt Id] -- the rest of the qual's
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
......@@ -478,7 +479,7 @@ mkUnzipBind _ elt_tys
--
-- [:e | qss:] = <<[:e | qss:]>> () [:():]
--
dsPArrComp :: [ExprStmt Id]
dsPArrComp :: [ExprStmt GhcTc]
-> DsM CoreExpr
-- Special case for parallel comprehension
......@@ -514,8 +515,8 @@ dsPArrComp qs = do -- no ParStmt in `qs'
-- the work horse
--
dePArrComp :: [ExprStmt Id]
-> LPat Id -- the current generator pattern
dePArrComp :: [ExprStmt GhcTc]
-> LPat GhcTc -- the current generator pattern
-> CoreExpr -- the current generator expression
-> DsM CoreExpr
......@@ -612,7 +613,7 @@ dePArrComp (ApplicativeStmt {} : _) _ _ =
-- where
-- {x_1, ..., x_n} = DV (qs)
--
dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr
dePArrParComp :: [ParStmtBlock GhcTc GhcTc] -> [ExprStmt GhcTc] -> DsM CoreExpr
dePArrParComp qss quals = do
(pQss, ceQss) <- deParStmt qss
dePArrComp quals pQss ceQss
......@@ -639,8 +640,8 @@ dePArrParComp qss quals = do
-- generate Core corresponding to `\p -> e'
--
deLambda :: Type -- type of the argument (not levity-polymorphic)
-> LPat Id -- argument pattern
-> LHsExpr Id -- body
-> LPat GhcTc -- argument pattern
-> LHsExpr GhcTc -- body
-> DsM (CoreExpr, Type)
deLambda ty p e =
mkLambda ty p =<< dsLExpr e
......@@ -648,7 +649,7 @@ deLambda ty p e =
-- generate Core for a lambda pattern match, where the body is already in Core
--
mkLambda :: Type -- type of the argument (not levity-polymorphic)
-> LPat Id -- argument pattern
-> LPat GhcTc -- argument pattern
-> CoreExpr -- desugared body
-> DsM (CoreExpr, Type)
mkLambda ty p ce = do
......@@ -672,15 +673,15 @@ parrElemType e =
-- Translation for monad comprehensions
-- Entry point for monad comprehension desugaring
dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr
dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr
dsMonadComp stmts = dsMcStmts stmts
dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr
dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr
dsMcStmts [] = panic "dsMcStmts"
dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
---------------
dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr
dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsMcStmt (LastStmt body _ ret_op) stmts
= ASSERT( null stmts )
......@@ -803,12 +804,12 @@ matchTuple ids body
-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
-- desugared `CoreExpr`
dsMcBindStmt :: LPat Id
dsMcBindStmt :: LPat GhcTc
-> CoreExpr -- ^ the desugared rhs of the bind statement
-> SyntaxExpr Id
-> SyntaxExpr Id
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> Type -- ^ S in (>>=) :: Q -> (R -> S) -> T
-> [ExprLStmt Id]
-> [ExprLStmt GhcTc]
-> DsM CoreExpr
dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
= do { body <- dsMcStmts stmts
......@@ -840,9 +841,9 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
-- returns the desugaring of
-- [ (a,b,c) | quals ]
dsInnerMonadComp :: [ExprLStmt Id]
-> [Id] -- Return a tuple of these variables
-> SyntaxExpr Id -- The monomorphic "return" operator
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 (mkBigLHsVarTupId bndrs) False ret_op)])
......@@ -860,7 +861,7 @@ dsInnerMonadComp stmts bndrs ret_op
-- , fmap (selN2 :: (t1, t2) -> t2) ys )
mkMcUnzipM :: TransForm
-> HsExpr TcId -- fmap
-> 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)
......
This diff is collapsed.
......@@ -105,7 +105,7 @@ instance Outputable DsMatchContext where
ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
data EquationInfo
= EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
= EqnInfo { eqn_pats :: [Pat GhcTc], -- The patterns for an eqn
eqn_rhs :: MatchResult } -- What to do after match
instance Outputable EquationInfo where
......
......@@ -92,7 +92,7 @@ hand, which should indeed be bound to the pattern as a whole, then use it;
otherwise, make one up.
-}
selectSimpleMatchVarL :: LPat Id -> DsM Id
selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
-- (selectMatchVars ps tys) chooses variables of type tys
......@@ -111,10 +111,10 @@ selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
-- 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 Id] -> DsM [Id]
selectMatchVars :: [Pat GhcTc] -> DsM [Id]
selectMatchVars ps = mapM selectMatchVar ps
selectMatchVar :: Pat Id -> DsM Id
selectMatchVar :: Pat GhcTc -> DsM Id
selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
......@@ -174,7 +174,7 @@ The ``equation info'' used by @match@ is relatively complicated and
worthy of a type synonym and a few handy functions.
-}
firstPat :: EquationInfo -> Pat Id
firstPat :: EquationInfo -> Pat GhcTc
firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
shiftEqns :: [EquationInfo] -> [EquationInfo]
......@@ -255,7 +255,7 @@ mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
= MatchResult CanFail (\fail -> do body <- body_fn fail
return (mkIfThenElse pred_expr body fail))
mkCoPrimCaseMatchResult :: Id -- Scrutinee
mkCoPrimCaseMatchResult :: Id -- Scrutinee
-> Type -- Type of the case
-> [(Literal, MatchResult)] -- Alternatives
-> MatchResult -- Literals are all unlifted
......@@ -414,7 +414,8 @@ mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
-- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
-- case
--
mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr
mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr
-> DsM CoreExpr
mkPArrCase dflags var ty sorted_alts fail = do
lengthP <- dsDPHBuiltin lengthPVar
alt <- unboxAlt
......@@ -725,7 +726,7 @@ work out well:
-}
mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
-> LPat Id -- ^ The pattern
-> 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
......@@ -814,31 +815,31 @@ is_triv_pat _ = False
* *
********************************************************************* -}
mkLHsPatTup :: [LPat Id] -> LPat Id
mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats = L (getLoc (head lpats)) $
mkVanillaTuplePat lpats Boxed
mkLHsVarPatTup :: [Id] -> LPat Id