Commit 509d5be6 authored by Shayan-Najd's avatar Shayan-Najd Committed by Alan Zimmerman

[TTG: Handling Source Locations] Foundation and Pat

This patch removes the ping-pong style from HsPat (only, for now),
using the plan laid out at
https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/HandlingSourceLocations (solution
A).

- the class `HasSrcSpan`, and its functions (e.g., `cL` and `dL`), are introduced
- some instances of `HasSrcSpan` are introduced
- some constructors `L` are replaced with `cL`
- some patterns `L` are replaced with `dL->L` view pattern
- some type annotation are necessarily updated (e.g., `Pat p` --> `Pat (GhcPass p)`)

Phab diff: D5036
Trac Issues #15495

Updates haddock submodule
parent ad2d7612
......@@ -6,6 +6,9 @@
-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms #-}
-- |
-- #name_types#
......@@ -202,6 +205,12 @@ nameOccName name = n_occ name
nameSrcLoc name = srcSpanStart (n_loc name)
nameSrcSpan name = n_loc name
type instance SrcSpanLess Name = Name
instance HasSrcSpan Name where
composeSrcSpan (L sp n) = n {n_loc = sp}
decomposeSrcSpan n = L (n_loc n) n
{-
************************************************************************
* *
......@@ -668,7 +677,7 @@ class NamedThing a where
getOccName n = nameOccName (getName n) -- Default method
instance NamedThing e => NamedThing (GenLocated l e) where
instance NamedThing e => NamedThing (Located e) where
getName = getName . unLoc
getSrcLoc :: NamedThing a => a -> SrcLoc
......
......@@ -7,6 +7,11 @@
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
-- | This module contains types that relate to the positions of things
-- in source files, and allow tagging of those things with locations
......@@ -70,11 +75,16 @@ module SrcLoc (
-- ** Deconstructing Located
getLoc, unLoc,
unRealSrcSpan, getRealSrcSpan,
-- ** Combining and comparing Located values
eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost,
spans, isSubspanOf, sortLocated
spans, isSubspanOf, sortLocated,
-- ** HasSrcSpan
HasSrcSpan(..), SrcSpanLess, dL, cL,
pattern LL, onHasSrcSpan, liftL
) where
import GhcPrelude
......@@ -169,7 +179,7 @@ advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
************************************************************************
-}
sortLocated :: [Located a] -> [Located a]
sortLocated :: HasSrcSpan a => [a] -> [a]
sortLocated things = sortBy (comparing getLoc) things
instance Outputable RealSrcLoc where
......@@ -517,35 +527,36 @@ data GenLocated l e = L l e
type Located = GenLocated SrcSpan
type RealLocated = GenLocated RealSrcSpan
unLoc :: GenLocated l e -> e
unLoc (L _ e) = e
unLoc :: HasSrcSpan a => a -> SrcSpanLess a
unLoc (dL->L _ e) = e
getLoc :: GenLocated l e -> l
getLoc (L l _) = l
getLoc :: HasSrcSpan a => a -> SrcSpan
getLoc (dL->L l _) = l
noLoc :: e -> Located e
noLoc e = L noSrcSpan e
noLoc :: HasSrcSpan a => SrcSpanLess a -> a
noLoc e = cL noSrcSpan e
mkGeneralLocated :: String -> e -> Located e
mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e
mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e
mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e
combineLocs :: Located a -> Located b -> SrcSpan
combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)
-- | Combine locations from two 'Located' things and add them to a third thing
addCLoc :: Located a -> Located b -> c -> Located c
addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c
addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
a -> b -> SrcSpanLess c -> c
addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c
-- not clear whether to add a general Eq instance, but this is useful sometimes:
-- | Tests whether the two located things are equal
eqLocated :: Eq a => Located a -> Located a -> Bool
eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool
eqLocated a b = unLoc a == unLoc b
-- not clear whether to add a general Ord instance, but this is useful sometimes:
-- | Tests the ordering of the two located things
cmpLocated :: Ord a => Located a -> Located a -> Ordering
cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering
cmpLocated a b = unLoc a `compare` unLoc b
instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
......@@ -586,3 +597,94 @@ isSubspanOf src parent
| srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
| otherwise = srcSpanStart parent <= srcSpanStart src &&
srcSpanEnd parent >= srcSpanEnd src
{-
************************************************************************
* *
\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans}
* *
************************************************************************
-}
{-
Note [HasSrcSpan Typeclass]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To be able to uniformly set/get source location spans (of `SrcSpan`) in
syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`.
More details can be found at the following wiki page
ImplementingTreesThatGrow/HandlingSourceLocations
For most syntactic entities, the source location spans are stored in
a syntactic entity by a wapper constuctor (introduced by TTG's
new constructor extension), e.g., by `NewPat (WrapperPat sp pat)`
for a source location span `sp` and a pattern `pat`.
-}
-- | Determines the type of undecorated syntactic entities
-- For most syntactic entities `E`, where source location spans are
-- introduced by a wrapper construtor of the same syntactic entity,
-- we have `SrcSpanLess E = E`.
-- However, some syntactic entities have a different type compared to
-- a syntactic entity `e :: E` may have the type `Located E` when
-- decorated by wrapping it with `L sp e` for a source span `sp`.
type family SrcSpanLess a
-- | A typeclass to set/get SrcSpans
class HasSrcSpan a where
-- | Composes a `SrcSpan` decoration with an undecorated syntactic
-- entity to form its decorated variant
composeSrcSpan :: Located (SrcSpanLess a) -> a
-- | Decomposes a decorated syntactic entity into its `SrcSpan`
-- decoration and its undecorated variant
decomposeSrcSpan :: a -> Located (SrcSpanLess a)
{- laws:
composeSrcSpan . decomposeSrcSpan = id
decomposeSrcSpan . composeSrcSpan = id
in other words, `HasSrcSpan` defines an iso relation between
a `SrcSpan`-decorated syntactic entity and its undecorated variant
(together with the `SrcSpan`).
-}
type instance SrcSpanLess (GenLocated l e) = e
instance HasSrcSpan (Located a) where
composeSrcSpan = id
decomposeSrcSpan = id
-- | An abbreviated form of decomposeSrcSpan,
-- mainly to be used in ViewPatterns
dL :: HasSrcSpan a => a -> Located (SrcSpanLess a)
dL = decomposeSrcSpan
-- | An abbreviated form of composeSrcSpan,
-- mainly to replace the hardcoded `L`
cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL sp e = composeSrcSpan (L sp e)
-- | A Pattern Synonym to Set/Get SrcSpans
pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
pattern LL sp e <- (dL->L sp e)
where
LL sp e = cL sp e
-- | Lifts a function of undecorated entities to one of decorated ones
onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) =>
(SrcSpanLess a -> SrcSpanLess b) -> a -> b
onHasSrcSpan f (dL->L l e) = cL l (f e)
liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL f (dL->L loc a) = do
a' <- f a
return $ cL loc a'
getRealSrcSpan :: RealLocated a -> RealSrcSpan
getRealSrcSpan (L l _) = l
unRealSrcSpan :: RealLocated a -> a
unRealSrcSpan (L _ e) = e
......@@ -6,6 +6,7 @@ Pattern Matching Coverage Checking.
{-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Check (
-- Checking and printing
......@@ -342,7 +343,7 @@ checkSingle' locn var p = do
(Covered, _ ) -> PmResult prov [] us' [] -- useful
(NotCovered, NotDiverged) -> PmResult prov m us' [] -- redundant
(NotCovered, Diverged ) -> PmResult prov [] us' m -- inaccessible rhs
where m = [L locn [L locn p]]
where m = [cL locn [cL locn p]]
-- | Exhaustive for guard matches, is used for guards in pattern bindings and
-- in @MultiIf@ expressions.
......@@ -353,7 +354,7 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
dflags <- getDynFlags
let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
dsMatchContext = DsMatchContext hs_ctx combinedLoc
match = L combinedLoc $
match = cL combinedLoc $
Match { m_ext = noExt
, m_ctxt = hs_ctx
, m_pats = []
......@@ -419,8 +420,8 @@ checkMatches' vars matches
(NotCovered, Diverged ) -> (final_prov, rs, final_u, m:is)
hsLMatchToLPats :: LMatch id body -> Located [LPat id]
hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats
hsLMatchToLPats (L _ (XMatch _)) = panic "checMatches'"
hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats
hsLMatchToLPats _ = panic "checMatches'"
-- | Check an empty case expression. Since there are no clauses to process, we
-- only compute the uncovered set. See Note [Checking EmptyCase Expressions]
......@@ -986,7 +987,7 @@ translatePat fam_insts pat = case pat of
return [xp,g]
-- (n + k) ===> x (True <- x >= k) (n <- x-k)
NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
NPlusKPat ty (dL->L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
-- (fun -> pat) ===> x (pat <- fun x)
ViewPat arg_ty lexpr lpat -> do
......@@ -1031,7 +1032,7 @@ translatePat fam_insts pat = case pat of
-- pattern and do further translation as an optimization, for the reason,
-- see Note [Guards and Approximation].
ConPatOut { pat_con = L _ con
ConPatOut { pat_con = (dL->L _ con)
, pat_arg_tys = arg_tys
, pat_tvs = ex_tvs
, pat_dicts = dicts
......@@ -1048,7 +1049,7 @@ translatePat fam_insts pat = case pat of
, pm_con_args = args }]
-- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
NPat _ (L _ olit) mb_neg _
NPat _ (dL->L _ olit) mb_neg _
| OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit
, isStringTy ty ->
foldr (mkListPatVec charTy) [nilPattern charTy] <$>
......@@ -1216,7 +1217,7 @@ translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _))
-- Some label information
orig_lbls = map flSelector $ conLikeFieldLabels c
matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))
| L _ x <- fs]
| (dL->L _ x) <- fs]
matched_lbls = [ name | (name, _pat) <- matched_pats ]
subsetOf :: Eq a => [a] -> [a] -> Bool
......@@ -1229,18 +1230,19 @@ translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _))
-- Translate a single match
translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)
-> DsM (PatVec,[PatVec])
translateMatch fam_insts (L _ (Match { m_pats = lpats, m_grhss = grhss })) = do
translateMatch fam_insts (dL->L _ (Match { m_pats = lpats, m_grhss = grhss })) =
do
pats' <- concat <$> translatePatVec fam_insts pats
guards' <- mapM (translateGuards fam_insts) guards
return (pats', guards')
where
extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
extractGuards (L _ (GRHS _ gs _)) = map unLoc gs
extractGuards (L _ (XGRHS _)) = panic "translateMatch"
extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs
extractGuards _ = panic "translateMatch"
pats = map unLoc lpats
guards = map extractGuards (grhssGRHSs grhss)
translateMatch _ (L _ (XMatch _)) = panic "translateMatch"
translateMatch _ _ = panic "translateMatch"
-- -----------------------------------------------------------------------
-- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
......@@ -1304,7 +1306,7 @@ translateLet _binds = return []
-- | Translate a pattern guard
translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec
translateBind fam_insts (L _ p) e = do
translateBind fam_insts (dL->L _ p) e = do
ps <- translatePat fam_insts p
return [mkGuard ps (unLoc e)]
......@@ -2457,10 +2459,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
TypeOfUncovered _ -> True
UncoveredPatterns u -> notNull u)
when exists_r $ forM_ redundant $ \(L l q) -> do
when exists_r $ forM_ redundant $ \(dL->L l q) -> do
putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
(pprEqn q "is redundant"))
when exists_i $ forM_ inaccessible $ \(L l q) -> do
when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do
putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
(pprEqn q "has inaccessible right hand side"))
when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $
......@@ -2583,7 +2585,7 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
(ppr_match, pref)
= case kind of
FunRhs { mc_fun = L _ fun }
FunRhs { mc_fun = (dL->L _ fun) }
-> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp)
......
This diff is collapsed.
......@@ -8,6 +8,7 @@ The Desugarer: turning HsSyn into Core.
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Desugar (
-- * Desugaring operations
......@@ -379,13 +380,13 @@ Reason
-}
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 }))
dsRule (dL->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]
do { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars]
; lhs' <- unsetGOptM Opt_EnableRewriteRules $
unsetWOptM Opt_WarnIdentities $
......@@ -422,8 +423,8 @@ dsRule (L loc (HsRule { rd_name = name
; return (Just rule)
} } }
dsRule (L _ (XRuleDecl _)) = panic "dsRule"
dsRule (dL->L _ (XRuleDecl _)) = panic "dsRule"
dsRule _ = panic "dsRule: Impossible Match" -- due to #15884
warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
-- See Note [Rules and inlining/other rules]
......
This diff is collapsed.
......@@ -12,6 +12,8 @@ lower levels it is preserved with @let@/@letrec@s).
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
......@@ -98,7 +100,7 @@ dsTopLHsBinds binds
unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
bang_binds = filterBag (isBangedHsBind . unLoc) binds
top_level_err desc (L loc bind)
top_level_err desc (dL->L loc bind)
= putSrcSpanDs loc $
errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")
2 (ppr bind))
......@@ -115,8 +117,8 @@ dsLHsBinds binds
------------------------
dsLHsBind :: LHsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
dsLHsBind (L loc bind) = do dflags <- getDynFlags
putSrcSpanDs loc $ dsHsBind dflags bind
dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags
putSrcSpanDs loc $ dsHsBind dflags bind
-- | Desugar a single binding (or group of recursive binds).
dsHsBind :: DynFlags
......@@ -140,8 +142,10 @@ dsHsBind dflags (VarBind { var_id = var
else []
; return (force_var, [core_bind]) }
dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches
, fun_co_fn = co_fn, fun_tick = tick })
dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun)
, fun_matches = matches
, fun_co_fn = co_fn
, fun_tick = tick })
= do { (args, body) <- matchWrapper
(mkPrefixFunRhs (noLoc $ idName fun))
Nothing matches
......@@ -648,7 +652,7 @@ dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
-- 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))
dsSpec mb_poly_rhs (dL->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"
......
This diff is collapsed.
......@@ -9,6 +9,7 @@ Desugaring foreign declarations (see also DsCCall).
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module DsForeign ( dsForeigns ) where
......@@ -97,7 +98,7 @@ dsForeigns' fos = do
(vcat cs $$ vcat fe_init_code),
foldr (appOL . toOL) nilOL bindss)
where
do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
do_ldecl (dL->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)
......@@ -106,8 +107,10 @@ dsForeigns' fos = do
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
do_decl (ForeignExport { fd_name = (dL->L _ id)
, fd_e_ext = co
, fd_fe = CExport
(dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
do_decl (XForeignDecl _) = panic "dsForeigns'"
......
......@@ -7,6 +7,7 @@ Matching guarded right-hand-sides (GRHSs)
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
......@@ -67,9 +68,10 @@ dsGRHSs _ (XGRHSs _) _ = panic "dsGRHSs"
dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM MatchResult
dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs))
dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
dsGRHS _ _ (L _ (XGRHS _)) = panic "dsGRHS"
dsGRHS _ _ (dL->L _ (XGRHS _)) = panic "dsGRHS"
dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884
{-
************************************************************************
......
......@@ -8,6 +8,7 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions
{-# LANGUAGE CPP, NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module DsListComp ( dsListComp, dsMonadComp ) where
......@@ -483,8 +484,8 @@ 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)
dsMcStmts [] = panic "dsMcStmts"
dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
---------------
dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
......@@ -638,7 +639,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
| otherwise
= extractMatchResult match (error "It can't fail")
mk_fail_msg :: DynFlags -> Located e -> String
mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
mk_fail_msg dflags pat
= "Pattern match failure in monad comprehension at " ++
showPpr dflags (getLoc pat)
......
This diff is collapsed.
......@@ -8,6 +8,7 @@
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
{-# LANGUAGE ViewPatterns #-}
module DsMonad (
DsM, mapM, mapAndUnzipM,
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module DsUsage (
-- * Dependency/fingerprinting code (used by MkIface)
......
......@@ -11,6 +11,7 @@ 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 (
......@@ -668,7 +669,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
-- and all the desugared binds
mkSelectorBinds ticks pat val_expr
| L _ (VarPat _ (L _ v)) <- pat' -- Special case (A)
| (dL->L _ (VarPat _ (dL->L _ v))) <- pat' -- Special case (A)
= return (v, [(v, val_expr)])
| is_flat_prod_lpat pat' -- Special case (B)
......@@ -713,28 +714,29 @@ mkSelectorBinds ticks pat val_expr
local_tuple = mkBigCoreVarTup1 binders
tuple_ty = exprType local_tuple
strip_bangs :: LPat a -> LPat a
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
strip_bangs (dL->L _ (ParPat _ p)) = strip_bangs p
strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p
strip_bangs lp = lp
is_flat_prod_lpat :: LPat a -> Bool
is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
is_flat_prod_lpat = is_flat_prod_pat . unLoc
is_flat_prod_pat :: Pat a -> Bool
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})
is_flat_prod_pat (ConPatOut { pat_con = (dL->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 a -> Bool
is_triv_lpat p = is_triv_pat (unLoc p)
is_triv_lpat :: LPat (GhcPass p) -> Bool
is_triv_lpat = is_triv_pat . unLoc
is_triv_pat :: Pat a -> Bool
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
......@@ -752,7 +754,7 @@ is_triv_pat _ = False
mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats = L (getLoc (head lpats)) $
mkLHsPatTup lpats = cL (getLoc (head lpats)) $
mkVanillaTuplePat lpats Boxed
mkLHsVarPatTup :: [Id] -> LPat GhcTc
......@@ -948,25 +950,25 @@ decideBangHood dflags lpat
| otherwise -- -XStrict
= go lpat
where
go lp@(L l p)
go lp@(dL->L l p)
= case p of
ParPat x p -> L l (ParPat x (go p))
ParPat x p -> cL l (ParPat x (go p))
LazyPat _ lp' -> lp'
BangPat _ _ -> lp
_ -> L l (BangPat noExt lp)
_ -> cL l (BangPat noExt lp)
-- | Unconditionally make a 'Pat' strict.
addBang :: LPat GhcTc -- ^ Original pattern
-> LPat GhcTc -- ^ Banged pattern
addBang = go
where
go lp@(L l p)
go lp@(dL->L l p)
= case p of
ParPat x p -> L l (ParPat x (go p))
LazyPat _ lp' -> L l (BangPat noExt lp')
ParPat x p -> cL l (ParPat x (go p))
LazyPat _ lp' -> cL l (BangPat noExt lp')
-- Should we bring the extension value over?
BangPat _ _ -> lp
_ -> L l (BangPat noExt lp)
_ -> cL l (BangPat noExt lp)
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
......@@ -976,23 +978,24 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-- * 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
isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v)))
| v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
= Just return
-- trueDataConId doesn't have the same unique as trueDataCon
isTrueLHsExpr (L _ (HsConLikeOut _ con))
isTrueLHsExpr (dL->L _ (HsConLikeOut _ con))
| con `hasKey` getUnique trueDataCon = Just return
isTrueLHsExpr (L _ (HsTick _ tickish e))
isTrueLHsExpr (dL->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))
isTrueLHsExpr (dL->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 (dL->L _ (HsPar _ e)) = isTrueLHsExpr e
isTrueLHsExpr _ = Nothing
-- | Extract docs from the renamer output so they can be be serialized.
{-# language LambdaCase #-}
{-# language TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module ExtractDocs (extractDocs) where
import GhcPrelude
......@@ -110,7 +113,7 @@ user-written. This lets us relate Names (from ClsInsts) to comments
(associated with InstDecls and DerivDecls).
-}
getMainDeclBinder :: HsDecl pass -> [IdP pass]
getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder (TyClD _ d) = [tcdName d]
getMainDeclBinder (ValD _ d) =
case collectHsBindBinders d of
......@@ -137,13 +140,13 @@ getInstLoc :: InstDecl name -> 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
{ dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->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