[Git][ghc/ghc][wip/ttg-booleanformula] properly store locs in BooleanFormula nodes again
Hassan Al-Awwadi (@hassan.awwadi)
gitlab at gitlab.haskell.org
Sun Oct 27 14:01:25 UTC 2024
Hassan Al-Awwadi pushed to branch wip/ttg-booleanformula at Glasgow Haskell Compiler / GHC
Commits:
35fe87ee by Hassan Al-Awwadi at 2024-10-27T14:59:45+01:00
properly store locs in BooleanFormula nodes again
- - - - -
15 changed files:
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Parser.y
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Types/Basic.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/BooleanFormula.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
Changes:
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -43,6 +43,7 @@ module GHC.CoreToIface
, toIfaceVar
-- * Other stuff
, toIfaceLFInfo
+ , toIfaceBooleanFormula
-- * CgBreakInfo
, dehydrateCgBreakInfo
) where
@@ -69,6 +70,7 @@ import GHC.Builtin.Types ( heqTyCon )
import GHC.Iface.Syntax
import GHC.Data.FastString
+import GHC.Data.BooleanFormula qualified as BF(BooleanFormula(..))
import GHC.Types.Id
import GHC.Types.Id.Info
@@ -82,11 +84,14 @@ import GHC.Types.Var.Set
import GHC.Types.Tickish
import GHC.Types.Demand ( isNopSig )
import GHC.Types.Cpr ( topCprSig )
+import GHC.Types.SrcLoc (unLoc)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
+import GHC.Hs.Extension (GhcRn)
+
import Data.Maybe ( isNothing, catMaybes )
{- Note [Avoiding space leaks in toIface*]
@@ -537,6 +542,14 @@ toIfGuidance src guidance
, isStableSource src = IfWhen arity unsat_ok boring_ok
| otherwise = IfNoGuidance
+toIfaceBooleanFormula :: BF.BooleanFormula GhcRn -> IfaceBooleanFormula
+toIfaceBooleanFormula = go
+ where
+ go (BF.Var nm ) = IfVar $ mkIfLclName . getOccFS . unLoc $ nm
+ go (BF.And bfs ) = IfAnd $ map (go . unLoc) bfs
+ go (BF.Or bfs ) = IfOr $ map (go . unLoc) bfs
+ go (BF.Parens bf) = IfParens $ (go . unLoc) bf
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Data/BooleanFormula.hs
=====================================
@@ -50,9 +50,9 @@ bfMap :: (LIdP (GhcPass p) -> LIdP (GhcPass p'))
bfMap f = go
where
go (Var a ) = Var $ f a
- go (And bfs) = And $ map go bfs
- go (Or bfs) = Or $ map go bfs
- go (Parens bf ) = Parens $ go bf
+ go (And bfs) = And $ map (fmap go) bfs
+ go (Or bfs) = Or $ map (fmap go) bfs
+ go (Parens bf ) = Parens $ fmap go bf
bfTraverse :: Applicative f
=> (LIdP (GhcPass p) -> f (LIdP (GhcPass p')))
@@ -61,9 +61,9 @@ bfTraverse :: Applicative f
bfTraverse f = go
where
go (Var a ) = Var <$> f a
- go (And bfs) = And <$> traverse @[] go bfs
- go (Or bfs) = Or <$> traverse @[] go bfs
- go (Parens bf ) = Parens <$> go bf
+ go (And bfs) = And <$> traverse @[] (traverse go) bfs
+ go (Or bfs) = Or <$> traverse @[] (traverse go) bfs
+ go (Parens bf ) = Parens <$> traverse go bf
@@ -114,10 +114,10 @@ isTrue (And []) = True
isTrue _ = False
eval :: (LIdP (GhcPass p) -> Bool) -> BooleanFormula (GhcPass p) -> Bool
-eval f (Var x) = f x
-eval f (And xs) = all (eval f) xs
-eval f (Or xs) = any (eval f) xs
-eval f (Parens x) = eval f x
+eval f (Var x) = f x
+eval f (And xs) = all (eval f . unLoc) xs
+eval f (Or xs) = any (eval f . unLoc) xs
+eval f (Parens x) = eval f (unLoc x)
-- Simplify a boolean formula.
-- The argument function should give the truth of the atoms, or Nothing if undecided.
@@ -128,9 +128,9 @@ simplify :: forall p. Eq (LIdP (GhcPass p))
simplify f (Var a) = case f a of
Nothing -> Var a
Just b -> mkBool b
-simplify f (And xs) = mkAnd (map (simplify f) xs)
-simplify f (Or xs) = mkOr (map (simplify f) xs)
-simplify f (Parens x) = simplify f x
+simplify f (And xs) = mkAnd (map (fmap (simplify f)) xs)
+simplify f (Or xs) = mkOr (map (fmap (simplify f)) xs)
+simplify f (Parens x) = simplify f (unLoc x)
-- Test if a boolean formula is satisfied when the given values are assigned to the atoms
-- if it is, returns Nothing
@@ -152,11 +152,11 @@ isUnsatisfied f bf
-- If the boolean formula holds, does that mean that the given atom is always true?
impliesAtom :: Eq (IdP (GhcPass p)) => BooleanFormula (GhcPass p) -> LIdP (GhcPass p) -> Bool
-Var x `impliesAtom` y = unLoc x == unLoc y
-And xs `impliesAtom` y = any (`impliesAtom` y) xs
--- we have all of xs, so one of them implying y is enough
-Or xs `impliesAtom` y = all (`impliesAtom` y) xs
-Parens x `impliesAtom` y = x `impliesAtom` y
+Var x `impliesAtom` y = (unLoc x) == (unLoc y)
+And xs `impliesAtom` y = any (\x -> unLoc x `impliesAtom` y) xs
+ -- we have all of xs, so one of them implying y is enough
+Or xs `impliesAtom` y = all (\x -> unLoc x `impliesAtom` y) xs
+Parens x `impliesAtom` y = unLoc x `impliesAtom` y
implies :: (Uniquable (IdP (GhcPass p))) => BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p) -> Bool
implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2])
@@ -166,16 +166,16 @@ implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2])
case hyp of
Var x | memberClauseAtoms (unLoc x) r -> True
| otherwise -> go (extendClauseAtoms l (unLoc x)) { clauseExprs = hyps } r
- Parens hyp' -> go l { clauseExprs = hyp':hyps } r
- And hyps' -> go l { clauseExprs = hyps' ++ hyps } r
- Or hyps' -> all (\hyp' -> go l { clauseExprs = hyp':hyps } r) hyps'
+ Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r
+ And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r
+ Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps'
go l r at Clause{ clauseExprs = con:cons } =
case con of
Var x | memberClauseAtoms (unLoc x) l -> True
| otherwise -> go l (extendClauseAtoms r (unLoc x)) { clauseExprs = cons }
- Parens con' -> go l r { clauseExprs = con':cons }
- And cons' -> all (\con' -> go l r { clauseExprs = con':cons }) cons'
- Or cons' -> go l r { clauseExprs = cons' ++ cons }
+ Parens con' -> go l r { clauseExprs = unLoc con':cons }
+ And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons'
+ Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons }
go _ _ = False
-- A small sequent calculus proof engine.
@@ -203,10 +203,10 @@ pprBooleanFormula' pprVar pprAnd pprOr = go
where
go p (Var x) = pprVar p x
go p (And []) = cparen (p > 0) empty
- go p (And xs) = pprAnd p (map (go 3) xs)
+ go p (And xs) = pprAnd p (map (go 3 . unLoc) xs)
go _ (Or []) = keyword $ text "FALSE"
- go p (Or xs) = pprOr p (map (go 2) xs)
- go p (Parens x) = go p x
+ go p (Or xs) = pprOr p (map (go 2 . unLoc) xs)
+ go p (Parens x) = go p (unLoc x)
-- Pretty print in source syntax, "a | b | c,d,e"
pprBooleanFormula :: (Rational -> LIdP (GhcPass p) -> SDoc)
@@ -234,7 +234,7 @@ pprBooleanFormulaNormal :: OutputableBndrId p => BooleanFormula (GhcPass p) -> S
pprBooleanFormulaNormal = go
where
go (Var x) = pprPrefixOcc (unLoc x)
- go (And xs) = fsep $ punctuate comma (map go xs)
+ go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs)
go (Or []) = keyword $ text "FALSE"
- go (Or xs) = fsep $ intersperse vbar (map go xs)
- go (Parens x) = parens (go x)
+ go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs)
+ go (Parens x) = parens (go $ unLoc x)
\ No newline at end of file
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -36,7 +36,7 @@ import Language.Haskell.Syntax.Binds
import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind )
import {-# SOURCE #-} GHC.Hs.Pat (pprLPat )
-import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormulaNormal )
+import GHC.Data.BooleanFormula ( LBooleanFormula, pprBooleanFormulaNormal )
import GHC.Types.Tickish
import GHC.Hs.Extension
import GHC.Parser.Annotation
@@ -968,8 +968,8 @@ instance Outputable TcSpecPrag where
ppr (SpecPrag var _ inl)
= text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl
-pprMinimalSig :: OutputableBndrId p => BooleanFormula (GhcPass p) -> SDoc
-pprMinimalSig = pprBooleanFormulaNormal
+pprMinimalSig :: OutputableBndrId p => LBooleanFormula (GhcPass p) -> SDoc
+pprMinimalSig (L _ bf) = pprBooleanFormulaNormal bf
{-
************************************************************************
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -2043,10 +2043,7 @@ instance ToHie PendingTcSplice where
instance (HiePass p, Data (IdGhcP p))
=> ToHie (GenLocated SrcSpanAnnL (BooleanFormula (GhcPass p))) where
- toHie (L span form) = concatM [makeNode form (locA span), toHie form]
-instance (HiePass p, Data (IdGhcP p))
- => ToHie (BooleanFormula (GhcPass p)) where
- toHie formula = concatM $ case formula of
+ toHie (L span form) = concatM $ makeNode form (locA span) : case form of
Var a ->
[ toHie $ C Use a
]
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -37,7 +37,7 @@ module GHC.Iface.Syntax (
ifaceDeclFingerprints,
fromIfaceWarnings,
fromIfaceWarningTxt,
- toIfaceBooleanFormula, fromIfaceBooleanFormula,
+ fromIfaceBooleanFormula,
-- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
freeNamesIfConDecls,
@@ -216,29 +216,22 @@ data IfaceClassBody
ifMinDef :: IfaceBooleanFormula -- Minimal complete definition
}
+-- See also 'BooleanFormula'
data IfaceBooleanFormula
= IfVar IfLclName
| IfAnd [IfaceBooleanFormula]
| IfOr [IfaceBooleanFormula]
| IfParens IfaceBooleanFormula
-toIfaceBooleanFormula :: BooleanFormula GhcRn -> IfaceBooleanFormula
-toIfaceBooleanFormula = go
- where
- go (Var nm ) = IfVar $ mkIfLclName . getOccFS . unLoc $ nm
- go (And bfs ) = IfAnd $ map go bfs
- go (Or bfs ) = IfOr $ map go bfs
- go (Parens bf) = IfParens $ go bf
-
-- | note that this makes unbound names, so if you actually want
-- proper Names, you'll need to properly Rename it (lookupIfaceTop).
fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula GhcRn
fromIfaceBooleanFormula = go
where
go (IfVar nm ) = Var $ noLocA . mkUnboundName . mkVarOccFS . ifLclNameFS $ nm
- go (IfAnd bfs ) = And $ map go bfs
- go (IfOr bfs ) = Or $ map go bfs
- go (IfParens bf) = Parens $ go bf
+ go (IfAnd bfs ) = And $ map (noLocA . go) bfs
+ go (IfOr bfs ) = Or $ map (noLocA . go) bfs
+ go (IfParens bf) = Parens $ (noLocA . go) bf
data IfaceTyConParent
= IfNoParent
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -139,6 +139,7 @@ import Data.List.NonEmpty ( NonEmpty )
import qualified Data.List.NonEmpty as NE
import GHC.Builtin.Names (ioTyConName, rOOT_MAIN)
import GHC.Iface.Errors.Types
+import GHC.CoreToIface(toIfaceBooleanFormula)
import Language.Haskell.Syntax.BooleanFormula (mkOr, BooleanFormula)
import Language.Haskell.Syntax.BooleanFormula qualified as BF(BooleanFormula(..))
@@ -305,7 +306,7 @@ mergeIfaceDecl d1 d2
in d1 { ifBody = (ifBody d1) {
ifSigs = ops,
- ifMinDef = toIfaceBooleanFormula . mkOr . map fromIfaceBooleanFormula $ [ bf1, bf2]
+ ifMinDef = toIfaceBooleanFormula . mkOr . map (noLocA . fromIfaceBooleanFormula) $ [ bf1, bf2]
}
} `withRolesFrom` d2
-- It doesn't matter; we'll check for consistency later when
@@ -851,11 +852,12 @@ tc_iface_decl _parent ignore_prags
return (ATI tc mb_def)
tc_boolean_formula :: IfaceBooleanFormula -> IfL (BooleanFormula GhcRn)
- tc_boolean_formula (IfVar nm ) = BF.Var . noLocA <$>
- (lookupIfaceTop . mkVarOccFS . ifLclNameFS) nm
- tc_boolean_formula (IfAnd ibfs ) = BF.And <$> traverse tc_boolean_formula ibfs
- tc_boolean_formula (IfOr ibfs ) = BF.Or <$> traverse tc_boolean_formula ibfs
- tc_boolean_formula (IfParens ibf) = BF.Parens <$> tc_boolean_formula ibf
+ tc_boolean_formula (IfAnd ibfs ) = BF.And . map noLocA <$> traverse tc_boolean_formula ibfs
+ tc_boolean_formula (IfOr ibfs ) = BF.Or . map noLocA <$> traverse tc_boolean_formula ibfs
+ tc_boolean_formula (IfParens ibf) = BF.Parens . noLocA <$> tc_boolean_formula ibf
+ tc_boolean_formula (IfVar nm ) = BF.Var . noLocA <$> tc_id nm
+ where
+ tc_id = lookupIfaceTop . mkVarOccFS . ifLclNameFS
mk_sc_doc pred = text "Superclass" <+> ppr pred
mk_at_doc tc = text "Associated type" <+> ppr tc
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3715,26 +3715,30 @@ overloaded_label :: { Located (SourceText, FastString) }
-----------------------------------------------------------------------------
-- Warnings and deprecations
-name_boolformula_opt :: { BooleanFormula GhcPs }
+name_boolformula_opt :: { LBooleanFormula GhcPs }
: name_boolformula { $1 }
- | {- empty -} { mkTrue }
+ | {- empty -} { noLocA mkTrue }
-name_boolformula :: { BooleanFormula GhcPs }
- : name_boolformula_and { $1 }
+name_boolformula :: { LBooleanFormula GhcPs }
+ : name_boolformula_and { $1 }
| name_boolformula_and '|' name_boolformula
- { (Or [$1, $3]) }
+ {% do { h <- addTrailingVbarL $1 (gl $2)
+ ; return (sLLa $1 $> (Or [h,$3])) } }
-name_boolformula_and :: { BooleanFormula GhcPs }
- : name_boolformula_and_list { (And ($1)) }
+name_boolformula_and :: { LBooleanFormula GhcPs }
+ : name_boolformula_and_list
+ { sLLa (head $1) (last $1) (And ($1)) }
-name_boolformula_and_list :: { [BooleanFormula GhcPs] }
- : name_boolformula_atom { [$1] }
+name_boolformula_and_list :: { [LBooleanFormula GhcPs] }
+ : name_boolformula_atom { [$1] }
| name_boolformula_atom ',' name_boolformula_and_list
- { ($1 : $3) }
+ {% do { h <- addTrailingCommaL $1 (gl $2)
+ ; return (h : $3) } }
-name_boolformula_atom :: { BooleanFormula GhcPs }
- : '(' name_boolformula ')' { (Parens $2) }
- | name_var { (Var $1) }
+name_boolformula_atom :: { LBooleanFormula GhcPs }
+ : '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens $2))
+ (AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) }
+ | name_var { sL1a $1 (Var $1) }
namelist :: { Located [LocatedN RdrName] }
namelist : name_var { sL1 $1 [$1] }
@@ -4742,4 +4746,4 @@ combineHasLocs a b = combineSrcSpans (getHasLoc a) (getHasLoc b)
fromTrailingN :: SrcSpanAnnN -> SrcSpanAnnA
fromTrailingN (EpAnn anc ann cs)
= EpAnn anc (AnnListItem (nann_trailing ann)) cs
-}
+}
\ No newline at end of file
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -1137,9 +1137,9 @@ renameSig ctxt (FixSig _ fsig)
= do { new_fsig <- rnSrcFixityDecl ctxt fsig
; return (FixSig noAnn new_fsig, emptyFVs) }
-renameSig ctxt sig@(MinimalSig (_, s) bf)
+renameSig ctxt sig@(MinimalSig (_, s) (L l bf))
= do new_bf <- bfTraverse (lookupSigOccRnN ctxt sig) bf
- return (MinimalSig (noAnn, s) new_bf, emptyFVs)
+ return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs)
renameSig ctxt sig@(PatSynSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs
=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -344,7 +344,7 @@ tcClassMinimalDef _clas sigs op_info
where
-- By default require all methods without a default implementation
defMindef :: ClassMinimalDef
- defMindef = mkAnd [ mkVar (noLocA name)
+ defMindef = mkAnd [ noLocA (mkVar (noLocA name))
| (name, _, Nothing) <- op_info ]
instantiateMethod :: Class -> TcId -> [TcType] -> TcType
@@ -402,7 +402,7 @@ findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef = firstJusts . map toMinimalDef
where
toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
- toMinimalDef (L _ (MinimalSig _ bf)) = Just bf
+ toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just bf
toMinimalDef _ = Nothing
{-
@@ -603,4 +603,4 @@ warnMissingAT name
$ InvalidAssoc $ InvalidAssocInstance
$ AssocInstanceMissing name
; diagnosticTc (warn && hsc_src == HsSrcFile) diag
- }
+ }
\ No newline at end of file
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -127,19 +127,6 @@ import GHC.Prelude
import GHC.ForeignSrcLang
import GHC.Data.FastString
import GHC.Utils.Outputable
- ( SDoc,
- Outputable(..),
- IsLine((<+>), sep, ftext, fsep, char, text, (<>)),
- IsOutput(empty),
- JoinPointHood(..),
- parens,
- vbar,
- brackets,
- ifPprDebug,
- doubleQuotes,
- int,
- isJoinPoint,
- OutputableP(..) )
import GHC.Utils.Panic
import GHC.Utils.Binary
import GHC.Types.SourceText
=====================================
compiler/Language/Haskell/Syntax/Binds.hs
=====================================
@@ -26,10 +26,8 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr
( LHsExpr
, MatchGroup
, GRHSs )
-import {-# SOURCE #-} Language.Haskell.Syntax.Pat
- ( LPat )
-import Language.Haskell.Syntax.BooleanFormula (BooleanFormula)
-
+import {-# SOURCE #-} Language.Haskell.Syntax.Pat( LPat )
+import Language.Haskell.Syntax.BooleanFormula (LBooleanFormula)
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Type
import Language.Haskell.Syntax.Basic ( Fixity )
@@ -464,7 +462,7 @@ data Sig pass
-- 'GHC.Parser.Annotation.AnnClose'
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
- | MinimalSig (XMinimalSig pass) (BooleanFormula pass)
+ | MinimalSig (XMinimalSig pass) (LBooleanFormula pass)
-- | A "set cost centre" pragma for declarations
--
=====================================
compiler/Language/Haskell/Syntax/BooleanFormula.hs
=====================================
@@ -9,16 +9,16 @@ module Language.Haskell.Syntax.BooleanFormula(
import Prelude hiding ( init, last )
import Data.List ( nub )
-import Language.Haskell.Syntax.Extension (XRec, LIdP)
+import Language.Haskell.Syntax.Extension (XRec, UnXRec (..), LIdP)
-- types
type LBooleanFormula p = XRec p (BooleanFormula p)
-data BooleanFormula p = Var (LIdP p) | And [BooleanFormula p] | Or [BooleanFormula p]
- | Parens (BooleanFormula p)
+data BooleanFormula p = Var (LIdP p) | And [LBooleanFormula p] | Or [LBooleanFormula p]
+ | Parens (LBooleanFormula p)
-- instances
-deriving instance Eq (LIdP p) => Eq (BooleanFormula p)
+deriving instance (Eq (LIdP p), Eq (LBooleanFormula p)) => Eq (BooleanFormula p)
-- smart constructors
-- see note [Simplification of BooleanFormulas]
@@ -35,28 +35,28 @@ mkBool False = mkFalse
mkBool True = mkTrue
-- Make a conjunction, and try to simplify
-mkAnd :: Eq (LIdP p) => [BooleanFormula p] -> BooleanFormula p
+mkAnd :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p
mkAnd = maybe mkFalse (mkAnd' . nub . concat) . mapM fromAnd
where
-- See Note [Simplification of BooleanFormulas]
- fromAnd :: BooleanFormula p -> Maybe [BooleanFormula p]
- fromAnd bf = case bf of
+ fromAnd :: LBooleanFormula p -> Maybe [LBooleanFormula p]
+ fromAnd bf = case unXRec @p bf of
(And xs) -> Just xs
-- assume that xs are already simplified
-- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs
(Or []) -> Nothing
-- in case of False we bail out, And [..,mkFalse,..] == mkFalse
_ -> Just [bf]
- mkAnd' [x] = x
+ mkAnd' [x] = unXRec @p x
mkAnd' xs = And xs
-mkOr :: Eq (LIdP p) => [BooleanFormula p] -> BooleanFormula p
+mkOr :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p
mkOr = maybe mkTrue (mkOr' . nub . concat) . mapM fromOr
where
-- See Note [Simplification of BooleanFormulas]
- fromOr bf = case bf of
+ fromOr bf = case unXRec @p bf of
(Or xs) -> Just xs
(And []) -> Nothing
_ -> Just [bf]
- mkOr' [x] = x
- mkOr' xs = Or xs
+ mkOr' [x] = unXRec @p x
+ mkOr' xs = Or xs
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -990,10 +990,10 @@ ppClassDecl
]
-- Minimal complete definition
- minimalBit = case [s | MinimalSig _ s <- sigs] of
+ minimalBit = case [s | MinimalSig _ (L _ s) <- sigs] of
-- Miminal complete definition = every shown method
And xs : _
- | sort [getName n | (Var (L _ n)) <- xs]
+ | sort [getName n | L _ (Var (L _ n)) <- xs]
== sort [getName n | ClassOpSig _ _ ns _ <- sigs, L _ n <- ns] ->
noHtml
-- Minimal complete definition = the only shown method
@@ -1007,11 +1007,11 @@ ppClassDecl
_ -> noHtml
ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n
- ppMinimal _ (And fs) = foldr1 (\a b -> a +++ ", " +++ b) $ map (ppMinimal True) fs
- ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ " | " +++ b) $ map (ppMinimal False ) fs
+ ppMinimal _ (And fs) = foldr1 (\a b -> a +++ ", " +++ b) $ map (ppMinimal True . unLoc) fs
+ ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ " | " +++ b) $ map (ppMinimal False . unLoc) fs
where
wrap | p = parens | otherwise = id
- ppMinimal p (Parens x) = ppMinimal p x
+ ppMinimal p (Parens x) = ppMinimal p (unLoc x)
-- Instances
instancesBit =
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -177,7 +177,7 @@ tyThingToLHsDecl prr t = case t of
$ snd
$ classTvsFds cl
, tcdSigs =
- noLocA (MinimalSig (noAnn, NoSourceText) $ classMinimalDef cl)
+ noLocA (MinimalSig (noAnn, NoSourceText) . noLocA $ classMinimalDef cl)
: [ noLocA tcdSig
| clsOp <- classOpItems cl
, tcdSig <- synifyTcIdSig vs clsOp
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -772,9 +772,9 @@ renameSig sig = case sig of
FixSig _ (FixitySig _ lnames fixity) -> do
lnames' <- mapM renameNameL lnames
return $ FixSig noExtField (FixitySig noExtField lnames' fixity)
- MinimalSig _ s -> do
+ MinimalSig _ (L l s) -> do
s' <- bfTraverse (traverse lookupRn) s
- return $ MinimalSig noExtField s'
+ return $ MinimalSig noExtField (L l s')
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
@@ -782,12 +782,12 @@ bfTraverse :: Applicative f
=> (LIdP (GhcPass p) -> f (LIdP DocNameI))
-> BooleanFormula (GhcPass p)
-> f (BooleanFormula DocNameI)
-bfTraverse f = go
- where
+bfTraverse f = go
+ where
go (Var a ) = Var <$> f a
- go (And bfs) = And <$> traverse @[] go bfs
- go (Or bfs) = Or <$> traverse @[] go bfs
- go (Parens bf ) = Parens <$> go bf
+ go (And bfs) = And <$> traverse @[] (traverse go) bfs
+ go (Or bfs) = Or <$> traverse @[] (traverse go) bfs
+ go (Parens bf ) = Parens <$> traverse go bf
renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)
renameForD (ForeignImport _ lname ltype x) = do
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35fe87ee309a87d7eaf72eca6cba538c0a90c420
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35fe87ee309a87d7eaf72eca6cba538c0a90c420
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/20241027/922b6be8/attachment-0001.html>
More information about the ghc-commits
mailing list