[Git][ghc/ghc][master] Introduce and use DerivClauseTys (#18662)
Marge Bot
gitlab at gitlab.haskell.org
Tue Sep 15 19:21:53 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
4283feaa by Ryan Scott at 2020-09-15T15:21:43-04:00
Introduce and use DerivClauseTys (#18662)
This switches `deriv_clause_tys` so that instead of using a list of
`LHsSigType`s to represent the types in a `deriving` clause, it now
uses a sum type. `DctSingle` represents a `deriving` clause with no
enclosing parentheses, while `DctMulti` represents a clause with
enclosing parentheses. This makes pretty-printing easier and avoids
confusion between `HsParTy` and the enclosing parentheses in
`deriving` clauses, which are different semantically.
Fixes #18662.
- - - - -
11 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/ThToHs.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -25,7 +25,8 @@
module GHC.Hs.Decls (
-- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,
- HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,
+ HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,
+ NewOrData(..), newOrDataToFlavour,
StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,
-- ** Class or type declarations
@@ -1321,15 +1322,8 @@ data HsDerivingClause pass
, deriv_clause_strategy :: Maybe (LDerivStrategy pass)
-- ^ The user-specified strategy (if any) to use when deriving
-- 'deriv_clause_tys'.
- , deriv_clause_tys :: XRec pass [LHsSigType pass]
+ , deriv_clause_tys :: LDerivClauseTys pass
-- ^ The types to derive.
- --
- -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,
- -- we can mention type variables that aren't bound by the datatype, e.g.
- --
- -- > data T b = ... deriving (C [a])
- --
- -- should produce a derived instance for @C [a] (T b)@.
}
| XHsDerivingClause !(XXHsDerivingClause pass)
@@ -1342,16 +1336,9 @@ instance OutputableBndrId p
, deriv_clause_tys = L _ dct })
= hsep [ text "deriving"
, pp_strat_before
- , pp_dct dct
+ , ppr dct
, pp_strat_after ]
where
- -- This complexity is to distinguish between
- -- deriving Show
- -- deriving (Show)
- pp_dct [HsIB { hsib_body = ty }]
- = ppr (parenthesizeHsType appPrec ty)
- pp_dct _ = parens (interpp'SP dct)
-
-- @via@ is unique in that in comes /after/ the class being derived,
-- so we must special-case it.
(pp_strat_before, pp_strat_after) =
@@ -1359,6 +1346,43 @@ instance OutputableBndrId p
Just (L _ via at ViaStrategy{}) -> (empty, ppr via)
_ -> (ppDerivStrategy dcs, empty)
+type LDerivClauseTys pass = XRec pass (DerivClauseTys pass)
+
+-- | The types mentioned in a single @deriving@ clause. This can come in two
+-- forms, 'DctSingle' or 'DctMulti', depending on whether the types are
+-- surrounded by enclosing parentheses or not. These parentheses are
+-- semantically differnt than 'HsParTy'. For example, @deriving ()@ means
+-- \"derive zero classes\" rather than \"derive an instance of the 0-tuple\".
+--
+-- 'DerivClauseTys' use 'LHsSigType' because @deriving@ clauses can mention
+-- type variables that aren't bound by the datatype, e.g.
+--
+-- > data T b = ... deriving (C [a])
+--
+-- should produce a derived instance for @C [a] (T b)@.
+data DerivClauseTys pass
+ = -- | A @deriving@ clause with a single type. Moreover, that type can only
+ -- be a type constructor without any arguments.
+ --
+ -- Example: @deriving Eq@
+ DctSingle (XDctSingle pass) (LHsSigType pass)
+
+ -- | A @deriving@ clause with a comma-separated list of types, surrounded
+ -- by enclosing parentheses.
+ --
+ -- Example: @deriving (Eq, C a)@
+ | DctMulti (XDctMulti pass) [LHsSigType pass]
+
+ | XDerivClauseTys !(XXDerivClauseTys pass)
+
+type instance XDctSingle (GhcPass _) = NoExtField
+type instance XDctMulti (GhcPass _) = NoExtField
+type instance XXDerivClauseTys (GhcPass _) = NoExtCon
+
+instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where
+ ppr (DctSingle _ ty) = ppr ty
+ ppr (DctMulti _ tys) = parens (interpp'SP tys)
+
-- | Located Standalone Kind Signature
type LStandaloneKindSig pass = XRec pass (StandaloneKindSig pass)
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -446,6 +446,12 @@ type family XXHsDataDefn x
type family XCHsDerivingClause x
type family XXHsDerivingClause x
+-- -------------------------------------
+-- DerivClauseTys type families
+type family XDctSingle x
+type family XDctMulti x
+type family XXDerivClauseTys x
+
-- -------------------------------------
-- ConDecl type families
type family XConDeclGADT x
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -163,6 +163,11 @@ deriving instance Data (HsDerivingClause GhcPs)
deriving instance Data (HsDerivingClause GhcRn)
deriving instance Data (HsDerivingClause GhcTc)
+-- deriving instance DataIdLR p p => Data (DerivClauseTys p)
+deriving instance Data (DerivClauseTys GhcPs)
+deriving instance Data (DerivClauseTys GhcRn)
+deriving instance Data (DerivClauseTys GhcTc)
+
-- deriving instance (DataIdLR p p) => Data (ConDecl p)
deriving instance Data (ConDecl GhcPs)
deriving instance Data (ConDecl GhcRn)
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -193,13 +193,19 @@ subordinates instMap decl = case decl of
, (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) $
+ | (l, doc) <- concatMap (extract_deriv_clause_tys .
+ deriv_clause_tys . unLoc) $
unLoc $ dd_derivs dd
, Just instName <- [lookupSrcSpan l instMap] ]
- extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
- extract_deriv_ty (L l ty) =
+ extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)]
+ extract_deriv_clause_tys (L _ dct) =
+ case dct of
+ DctSingle _ ty -> maybeToList $ extract_deriv_ty ty
+ DctMulti _ tys -> mapMaybe extract_deriv_ty tys
+
+ extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)
+ extract_deriv_ty (HsIB{hsib_body = L l ty}) =
case ty of
-- deriving (forall a. C a {- ^ Doc comment -})
HsForAllTy{ hst_tele = HsForAllInvis{}
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -945,13 +945,18 @@ repDerivClause :: LHsDerivingClause GhcRn
-> MetaM (Core (M TH.DerivClause))
repDerivClause (L _ (HsDerivingClause
{ deriv_clause_strategy = dcs
- , deriv_clause_tys = L _ dct }))
+ , deriv_clause_tys = dct }))
= repDerivStrategy dcs $ \(MkC dcs') ->
- do MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct
+ do MkC dct' <- rep_deriv_clause_tys dct
rep2 derivClauseName [dcs',dct']
where
- rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type))
- rep_deriv_ty ty = repLTy ty
+ rep_deriv_clause_tys :: LDerivClauseTys GhcRn -> MetaM (Core [M TH.Type])
+ rep_deriv_clause_tys (L _ dct) = case dct of
+ DctSingle _ ty -> rep_deriv_tys [ty]
+ DctMulti _ tys -> rep_deriv_tys tys
+
+ rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M TH.Type])
+ rep_deriv_tys = repListM typeTyConName (repLTy . hsSigType)
rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
-> MetaM ([GenSymBind], [Core (M TH.Dec)])
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1507,12 +1507,16 @@ instance ToHie (Located [Located (HsDerivingClause GhcRn)]) where
instance ToHie (Located (HsDerivingClause GhcRn)) where
toHie (L span cl) = concatM $ makeNode cl span : case cl of
- HsDerivingClause _ strat (L ispan tys) ->
+ HsDerivingClause _ strat dct ->
[ toHie strat
- , locOnly ispan
- , toHie $ map (TS (ResolvedScopes [])) tys
+ , toHie dct
]
+instance ToHie (Located (DerivClauseTys GhcRn)) where
+ toHie (L span dct) = concatM $ makeNode dct span : case dct of
+ DctSingle _ ty -> [ toHie $ TS (ResolvedScopes[]) ty ]
+ DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ]
+
instance ToHie (Located (DerivStrategy GhcRn)) where
toHie (L span strat) = concatM $ makeNode strat span : case strat of
StockStrategy -> []
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2276,15 +2276,13 @@ deriving :: { LHsDerivingClause GhcPs }
in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2)
[mj AnnDeriving $1] }
-deriv_clause_types :: { Located [LHsSigType GhcPs] }
+deriv_clause_types :: { LDerivClauseTys GhcPs }
: qtycon { let { tc = sL1 $1 (HsTyVar noExtField NotPromoted $1) } in
- sL1 $1 [mkLHsSigType tc] }
- | '(' ')' {% ams (sLL $1 $> [])
+ sL1 $1 (DctSingle noExtField (mkLHsSigType tc)) }
+ | '(' ')' {% ams (sLL $1 $> (DctMulti noExtField []))
[mop $1,mcp $2] }
- | '(' deriv_types ')' {% ams (sLL $1 $> $2)
+ | '(' deriv_types ')' {% ams (sLL $1 $> (DctMulti noExtField $2))
[mop $1,mcp $3] }
- -- Glasgow extension: allow partial
- -- applications in derivings
-----------------------------------------------------------------------------
-- Value definitions
=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -628,15 +628,34 @@ instance HasHaddock (Located (HsDerivingClause GhcPs)) where
Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA l)
Just (L l _) -> (registerLocHdkA l, pure ())
register_strategy_before
- deriv_clause_tys' <-
- extendHdkA (getLoc deriv_clause_tys) $
- traverse @Located addHaddock deriv_clause_tys
+ deriv_clause_tys' <- addHaddock deriv_clause_tys
register_strategy_after
pure HsDerivingClause
{ deriv_clause_ext = noExtField,
deriv_clause_strategy,
deriv_clause_tys = deriv_clause_tys' }
+-- Process the types in a single deriving clause, which may come in one of the
+-- following forms:
+--
+-- 1. A singular type constructor:
+-- deriving Eq -- ^ Comment on Eq
+--
+-- 2. A list of comma-separated types surrounded by enclosing parentheses:
+-- deriving ( Eq -- ^ Comment on Eq
+-- , C a -- ^ Comment on C a
+-- )
+instance HasHaddock (Located (DerivClauseTys GhcPs)) where
+ addHaddock (L l_dct dct) =
+ extendHdkA l_dct $
+ case dct of
+ DctSingle x ty -> do
+ ty' <- addHaddock ty
+ pure $ L l_dct $ DctSingle x ty'
+ DctMulti x tys -> do
+ tys' <- addHaddock tys
+ pure $ L l_dct $ DctMulti x tys'
+
-- Process a single data constructor declaration, which may come in one of the
-- following forms:
--
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -1895,15 +1895,25 @@ rnLHsDerivingClause doc
(L loc (HsDerivingClause
{ deriv_clause_ext = noExtField
, deriv_clause_strategy = dcs
- , deriv_clause_tys = L loc' dct }))
+ , deriv_clause_tys = dct }))
= do { (dcs', dct', fvs)
- <- rnLDerivStrategy doc dcs $ mapFvRn rn_clause_pred dct
+ <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct
; warnNoDerivStrat dcs' loc
; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField
, deriv_clause_strategy = dcs'
- , deriv_clause_tys = L loc' dct' })
+ , deriv_clause_tys = dct' })
, fvs ) }
where
+ rn_deriv_clause_tys :: LDerivClauseTys GhcPs
+ -> RnM (LDerivClauseTys GhcRn, FreeVars)
+ rn_deriv_clause_tys (L l dct) = case dct of
+ DctSingle x ty -> do
+ (ty', fvs) <- rn_clause_pred ty
+ pure (L l (DctSingle x ty'), fvs)
+ DctMulti x tys -> do
+ (tys', fvs) <- mapFvRn rn_clause_pred tys
+ pure (L l (DctMulti x tys'), fvs)
+
rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
rn_clause_pred pred_ty = do
let inf_err = Just (text "Inferred type variables are not allowed")
=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -437,17 +437,22 @@ makeDerivSpecs :: [DerivInfo]
-> TcM [EarlyDerivSpec]
makeDerivSpecs deriv_infos deriv_decls
= do { eqns1 <- sequenceA
- [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt
+ [ deriveClause rep_tc scoped_tvs dcs (deriv_clause_preds dct) err_ctxt
| DerivInfo { di_rep_tc = rep_tc
, di_scoped_tvs = scoped_tvs
, di_clauses = clauses
, di_ctxt = err_ctxt } <- deriv_infos
, L _ (HsDerivingClause { deriv_clause_strategy = dcs
- , deriv_clause_tys = L _ preds })
+ , deriv_clause_tys = dct })
<- clauses
]
; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
; return $ concat eqns1 ++ catMaybes eqns2 }
+ where
+ deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
+ deriv_clause_preds (L _ dct) = case dct of
+ DctSingle _ ty -> [ty]
+ DctMulti _ tys -> tys
------------------------------------------------------------------
-- | Process the derived classes in a single @deriving@ clause.
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1393,12 +1393,25 @@ cvtContext p tys = do { preds' <- mapM cvtPred tys
cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
cvtPred = cvtType
+cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs)
+cvtDerivClauseTys tys
+ = do { tys' <- mapM cvtType tys
+ -- Since TH.Cxt doesn't indicate the presence or absence of
+ -- parentheses in a deriving clause, we have to choose between
+ -- DctSingle and DctMulti somewhat arbitrarily. We opt to use DctMulti
+ -- unless the TH.Cxt is a singleton list whose type is a bare type
+ -- constructor with no arguments.
+ ; case tys' of
+ [ty'@(L l (HsTyVar _ NotPromoted _))]
+ -> return $ L l $ DctSingle noExtField $ mkLHsSigType ty'
+ _ -> returnL $ DctMulti noExtField (map mkLHsSigType tys') }
+
cvtDerivClause :: TH.DerivClause
-> CvtM (LHsDerivingClause GhcPs)
-cvtDerivClause (TH.DerivClause ds ctxt)
- = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt
- ; ds' <- traverse cvtDerivStrategy ds
- ; returnL $ HsDerivingClause noExtField ds' ctxt' }
+cvtDerivClause (TH.DerivClause ds tys)
+ = do { tys' <- cvtDerivClauseTys tys
+ ; ds' <- traverse cvtDerivStrategy ds
+ ; returnL $ HsDerivingClause noExtField ds' tys' }
cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4283feaa9e0826211f7a71d543054c989ea32965
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4283feaa9e0826211f7a71d543054c989ea32965
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200915/0284960e/attachment-0001.html>
More information about the ghc-commits
mailing list