From 97f600c647eb7a657a1c838a33dba59e18320164 Mon Sep 17 00:00:00 2001
From: Hassan Al-Awwadi <hassan.awwadi@gmail.com>
Date: Tue, 29 Oct 2024 18:41:40 +0100
Subject: [PATCH] Refactored BooleanFormula to be in line with TTG (#21592)
There are two parts to this commit.
* We moved the definition of BooleanFormula over to L.H.S.BooleanFormula
* We parameterized the BooleanFormula over the pass
The GHC specific details of BooleanFormula remain in Ghc.Data.BooleanFormula.
Because its parameterized over the pass its no longer a functor or
traversable, but we defined bfMap and bfTraverse for the cases where we
needed fmap and traverse originally. Most other changes are just churn.
-------------------------
Metric Decrease:
MultiLayerModulesTH_OneShot
-------------------------
---
compiler/GHC/Core/Class.hs | 5 +-
compiler/GHC/CoreToIface.hs | 13 ++
compiler/GHC/Data/BooleanFormula.hs | 168 +++++++++---------
compiler/GHC/Hs/Binds.hs | 7 +-
compiler/GHC/Hs/Decls.hs | 3 +-
compiler/GHC/Hs/Instances.hs | 5 +
compiler/GHC/Iface/Decl.hs | 14 +-
compiler/GHC/Iface/Ext/Ast.hs | 5 +-
compiler/GHC/Iface/Syntax.hs | 30 ++--
compiler/GHC/IfaceToCore.hs | 47 ++++-
compiler/GHC/Parser.y | 18 +-
compiler/GHC/Rename/Bind.hs | 3 +-
compiler/GHC/Tc/TyCl/Class.hs | 8 +-
compiler/GHC/Tc/TyCl/Instance.hs | 2 +-
compiler/Language/Haskell/Syntax/Binds.hs | 8 +-
.../Language/Haskell/Syntax/BooleanFormula.hs | 62 +++++++
compiler/ghc.cabal.in | 1 +
.../tests/count-deps/CountDepsAst.stdout | 1 +
.../tests/count-deps/CountDepsParser.stdout | 1 +
utils/check-exact/ExactPrint.hs | 4 +-
.../haddock-api/src/Haddock/Convert.hs | 3 +-
.../src/Haddock/Interface/Rename.hs | 18 +-
.../haddock/haddock-api/src/Haddock/Types.hs | 2 +
23 files changed, 277 insertions(+), 151 deletions(-)
create mode 100644 compiler/Language/Haskell/Syntax/BooleanFormula.hs
diff --git a/compiler/GHC/Core/Class.hs b/compiler/GHC/Core/Class.hs
index 2d37607233a..603d2caf748 100644
--- a/compiler/GHC/Core/Class.hs
+++ b/compiler/GHC/Core/Class.hs
@@ -26,6 +26,7 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )
import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType )
import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType )
+import GHC.Hs.Extension (GhcRn)
import GHC.Types.Var
import GHC.Types.Name
import GHC.Types.Basic
@@ -35,7 +36,7 @@ import GHC.Utils.Panic
import GHC.Types.SrcLoc
import GHC.Types.Var.Set
import GHC.Utils.Outputable
-import GHC.Data.BooleanFormula (BooleanFormula, mkTrue)
+import Language.Haskell.Syntax.BooleanFormula ( BooleanFormula, mkTrue )
import qualified Data.Data as Data
@@ -131,7 +132,7 @@ data TyFamEqnValidityInfo
-- Note [Type-checking default assoc decls] in GHC.Tc.TyCl.
}
-type ClassMinimalDef = BooleanFormula Name -- Required methods
+type ClassMinimalDef = BooleanFormula GhcRn -- Required methods
data ClassBody
= AbstractClass
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index 6e786b111ca..32a8af16c88 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/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
+
{-
************************************************************************
* *
diff --git a/compiler/GHC/Data/BooleanFormula.hs b/compiler/GHC/Data/BooleanFormula.hs
index e65281aea73..1c5ebb33166 100644
--- a/compiler/GHC/Data/BooleanFormula.hs
+++ b/compiler/GHC/Data/BooleanFormula.hs
@@ -1,5 +1,6 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveTraversable #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies #-}
--------------------------------------------------------------------------------
-- | Boolean formulas without quantifiers and without negation.
@@ -8,73 +9,62 @@
-- This module is used to represent minimal complete definitions for classes.
--
module GHC.Data.BooleanFormula (
- BooleanFormula(..), LBooleanFormula,
- mkFalse, mkTrue, mkAnd, mkOr, mkVar,
+ module Language.Haskell.Syntax.BooleanFormula,
isFalse, isTrue,
+ bfMap, bfTraverse,
eval, simplify, isUnsatisfied,
implies, impliesAtom,
- pprBooleanFormula, pprBooleanFormulaNice
+ pprBooleanFormula, pprBooleanFormulaNice, pprBooleanFormulaNormal
) where
-import GHC.Prelude hiding ( init, last )
-
-import Data.List ( nub, intersperse )
+import Data.List ( intersperse )
import Data.List.NonEmpty ( NonEmpty (..), init, last )
-import Data.Data
-import GHC.Utils.Monad
-import GHC.Utils.Outputable
-import GHC.Parser.Annotation ( LocatedL )
-import GHC.Types.SrcLoc
+import GHC.Prelude hiding ( init, last )
import GHC.Types.Unique
import GHC.Types.Unique.Set
+import GHC.Types.SrcLoc (unLoc)
+import GHC.Utils.Outputable
+import GHC.Parser.Annotation ( SrcSpanAnnL )
+import GHC.Hs.Extension (GhcPass (..), OutputableBndrId)
+import Language.Haskell.Syntax.Extension (Anno, LIdP, IdP)
+import Language.Haskell.Syntax.BooleanFormula
+
----------------------------------------------------------------------
-- Boolean formula type and smart constructors
----------------------------------------------------------------------
-type LBooleanFormula a = LocatedL (BooleanFormula a)
-
-data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a]
- | Parens (LBooleanFormula a)
- deriving (Eq, Data, Functor, Foldable, Traversable)
-
-mkVar :: a -> BooleanFormula a
-mkVar = Var
+type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnL
-mkFalse, mkTrue :: BooleanFormula a
-mkFalse = Or []
-mkTrue = And []
+-- if we had Functor/Traversable (LbooleanFormula p) we could use that
+-- as a constraint and we wouldn't need to specialize to just GhcPass p,
+-- but becuase LBooleanFormula is a type synonym such a constraint is
+-- impossible.
--- Convert a Bool to a BooleanFormula
-mkBool :: Bool -> BooleanFormula a
-mkBool False = mkFalse
-mkBool True = mkTrue
-
--- Make a conjunction, and try to simplify
-mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a
-mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd
+-- BooleanFormula can't be an instance of functor because it can't lift
+-- arbitrary functions `a -> b`, only functions of type `LIdP a -> LIdP b`
+-- ditto for Traversable.
+bfMap :: (LIdP (GhcPass p) -> LIdP (GhcPass p'))
+ -> BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p')
+bfMap f = go
where
- -- See Note [Simplification of BooleanFormulas]
- fromAnd :: LBooleanFormula a -> Maybe [LBooleanFormula a]
- fromAnd (L _ (And xs)) = Just xs
- -- assume that xs are already simplified
- -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs
- fromAnd (L _ (Or [])) = Nothing
- -- in case of False we bail out, And [..,mkFalse,..] == mkFalse
- fromAnd x = Just [x]
- mkAnd' [x] = unLoc x
- mkAnd' xs = And xs
-
-mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a
-mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr
+ go (Var a ) = Var $ f a
+ 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')))
+ -> BooleanFormula (GhcPass p)
+ -> f (BooleanFormula (GhcPass p'))
+bfTraverse f = go
where
- -- See Note [Simplification of BooleanFormulas]
- fromOr (L _ (Or xs)) = Just xs
- fromOr (L _ (And [])) = Nothing
- fromOr x = Just [x]
- mkOr' [x] = unLoc x
- mkOr' xs = Or xs
+ go (Var a ) = Var <$> f a
+ go (And bfs) = And <$> traverse @[] (traverse go) bfs
+ go (Or bfs) = Or <$> traverse @[] (traverse go) bfs
+ go (Parens bf ) = Parens <$> traverse go bf
+
{-
@@ -115,15 +105,15 @@ We don't show a ridiculous error message like
-- Evaluation and simplification
----------------------------------------------------------------------
-isFalse :: BooleanFormula a -> Bool
+isFalse :: BooleanFormula (GhcPass p) -> Bool
isFalse (Or []) = True
isFalse _ = False
-isTrue :: BooleanFormula a -> Bool
+isTrue :: BooleanFormula (GhcPass p) -> Bool
isTrue (And []) = True
isTrue _ = False
-eval :: (a -> Bool) -> BooleanFormula a -> Bool
+eval :: (LIdP (GhcPass p) -> Bool) -> BooleanFormula (GhcPass p) -> Bool
eval f (Var x) = f x
eval f (And xs) = all (eval f . unLoc) xs
eval f (Or xs) = any (eval f . unLoc) xs
@@ -131,18 +121,24 @@ 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.
-simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a
+simplify :: forall p. Eq (LIdP (GhcPass p))
+ => (LIdP (GhcPass p) -> Maybe Bool)
+ -> BooleanFormula (GhcPass p)
+ -> BooleanFormula (GhcPass p)
simplify f (Var a) = case f a of
Nothing -> Var a
Just b -> mkBool b
-simplify f (And xs) = mkAnd (map (\(L l x) -> L l (simplify f x)) xs)
-simplify f (Or xs) = mkOr (map (\(L l x) -> L l (simplify f x)) xs)
+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
-- if it is not, return (Just remainder)
-isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)
+isUnsatisfied :: Eq (LIdP (GhcPass p))
+ => (LIdP (GhcPass p) -> Bool)
+ -> BooleanFormula (GhcPass p)
+ -> Maybe (BooleanFormula (GhcPass p))
isUnsatisfied f bf
| isTrue bf' = Nothing
| otherwise = Just bf'
@@ -155,42 +151,42 @@ isUnsatisfied f bf
-- eval f x == False <==> isFalse (simplify (Just . f) x)
-- If the boolean formula holds, does that mean that the given atom is always true?
-impliesAtom :: Eq a => BooleanFormula a -> a -> Bool
-Var x `impliesAtom` y = x == y
-And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs
+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 (\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
+Or xs `impliesAtom` y = all (\x -> unLoc x `impliesAtom` y) xs
+Parens x `impliesAtom` y = unLoc x `impliesAtom` y
-implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool
+implies :: (Uniquable (IdP (GhcPass p))) => BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p) -> Bool
implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2])
where
- go :: Uniquable a => Clause a -> Clause a -> Bool
+ go :: Uniquable (IdP (GhcPass p)) => Clause (GhcPass p) -> Clause (GhcPass p) -> Bool
go l@Clause{ clauseExprs = hyp:hyps } r =
case hyp of
- Var x | memberClauseAtoms x r -> True
- | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r
+ Var x | memberClauseAtoms (unLoc x) r -> True
+ | otherwise -> go (extendClauseAtoms l (unLoc x)) { clauseExprs = hyps } r
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@Clause{ clauseExprs = con:cons } =
case con of
- Var x | memberClauseAtoms x l -> True
- | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons }
+ Var x | memberClauseAtoms (unLoc x) l -> True
+ | otherwise -> go l (extendClauseAtoms r (unLoc x)) { clauseExprs = 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.
-data Clause a = Clause {
- clauseAtoms :: UniqSet a,
- clauseExprs :: [BooleanFormula a]
+data Clause p = Clause {
+ clauseAtoms :: UniqSet (IdP p),
+ clauseExprs :: [BooleanFormula p]
}
-extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a
+extendClauseAtoms :: Uniquable (IdP p) => Clause p -> IdP p -> Clause p
extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x }
-memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool
+memberClauseAtoms :: Uniquable (IdP p) => IdP p -> Clause p -> Bool
memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c
----------------------------------------------------------------------
@@ -199,28 +195,29 @@ memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c
-- Pretty print a BooleanFormula,
-- using the arguments as pretty printers for Var, And and Or respectively
-pprBooleanFormula' :: (Rational -> a -> SDoc)
- -> (Rational -> [SDoc] -> SDoc)
- -> (Rational -> [SDoc] -> SDoc)
- -> Rational -> BooleanFormula a -> SDoc
+pprBooleanFormula' :: (Rational -> LIdP (GhcPass p) -> SDoc)
+ -> (Rational -> [SDoc] -> SDoc)
+ -> (Rational -> [SDoc] -> SDoc)
+ -> Rational -> BooleanFormula (GhcPass p) -> SDoc
pprBooleanFormula' pprVar pprAnd pprOr = go
where
go p (Var x) = pprVar p x
- go p (And []) = cparen (p > 0) $ empty
+ go p (And []) = cparen (p > 0) empty
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 . unLoc) xs)
go p (Parens x) = go p (unLoc x)
-- Pretty print in source syntax, "a | b | c,d,e"
-pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc
+pprBooleanFormula :: (Rational -> LIdP (GhcPass p) -> SDoc)
+ -> Rational -> BooleanFormula (GhcPass p) -> SDoc
pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr
where
pprAnd p = cparen (p > 3) . fsep . punctuate comma
pprOr p = cparen (p > 2) . fsep . intersperse vbar
-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"?
-pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc
+pprBooleanFormulaNice :: Outputable (LIdP (GhcPass p)) => BooleanFormula (GhcPass p) -> SDoc
pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0
where
pprVar _ = quotes . ppr
@@ -230,15 +227,14 @@ pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0
pprAnd' (x:xs) = fsep (punctuate comma (init (x:|xs))) <> text ", and" <+> last (x:|xs)
pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs)
-instance (OutputableBndr a) => Outputable (BooleanFormula a) where
+instance OutputableBndrId p => Outputable (BooleanFormula (GhcPass p)) where
ppr = pprBooleanFormulaNormal
-pprBooleanFormulaNormal :: (OutputableBndr a)
- => BooleanFormula a -> SDoc
+pprBooleanFormulaNormal :: OutputableBndrId p => BooleanFormula (GhcPass p) -> SDoc
pprBooleanFormulaNormal = go
where
- go (Var x) = pprPrefixOcc x
+ go (Var x) = pprPrefixOcc (unLoc x)
go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs)
go (Or []) = keyword $ text "FALSE"
go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs)
- go (Parens x) = parens (go $ unLoc x)
+ go (Parens x) = parens (go $ unLoc x)
\ No newline at end of file
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index e76f143beeb..bd4669a29f1 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -36,6 +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 ( LBooleanFormula, pprBooleanFormulaNormal )
import GHC.Types.Tickish
import GHC.Hs.Extension
import GHC.Parser.Annotation
@@ -47,7 +48,6 @@ import GHC.Types.Basic
import GHC.Types.SourceText
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Var
-import GHC.Data.BooleanFormula (LBooleanFormula)
import GHC.Types.Name
import GHC.Utils.Outputable
@@ -968,9 +968,8 @@ instance Outputable TcSpecPrag where
ppr (SpecPrag var _ inl)
= text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl
-pprMinimalSig :: (OutputableBndr name)
- => LBooleanFormula (GenLocated l name) -> SDoc
-pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
+pprMinimalSig :: OutputableBndrId p => LBooleanFormula (GhcPass p) -> SDoc
+pprMinimalSig (L _ bf) = pprBooleanFormulaNormal bf
{-
************************************************************************
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index ea3bc7d2a4f..169ea5038a4 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -110,6 +110,7 @@ module GHC.Hs.Decls (
import GHC.Prelude
import Language.Haskell.Syntax.Decls
+import Language.Haskell.Syntax.Extension
import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice )
-- Because Expr imports Decls via HsBracket
@@ -119,7 +120,7 @@ import GHC.Hs.Type
import GHC.Hs.Doc
import GHC.Types.Basic
import GHC.Core.Coercion
-import Language.Haskell.Syntax.Extension
+
import GHC.Hs.Extension
import GHC.Parser.Annotation
import GHC.Types.Name
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index e60fae14398..0a3b8e93b7e 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -33,6 +33,8 @@ import GHC.Hs.Type
import GHC.Hs.Pat
import GHC.Hs.ImpExp
import GHC.Parser.Annotation
+import GHC.Data.BooleanFormula (BooleanFormula(..))
+import Language.Haskell.Syntax.Extension (Anno)
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs-----------------------------------------
@@ -590,3 +592,6 @@ deriving instance Data XXPatGhcTc
deriving instance Data XViaStrategyPs
-- ---------------------------------------------------------------------
+
+deriving instance (Typeable p, Data (Anno (IdGhcP p)), Data (IdGhcP p)) => Data (BooleanFormula (GhcPass p))
+---------------------------------------------------------------------
\ No newline at end of file
diff --git a/compiler/GHC/Iface/Decl.hs b/compiler/GHC/Iface/Decl.hs
index aaf10cd4ffc..11df02ee96c 100644
--- a/compiler/GHC/Iface/Decl.hs
+++ b/compiler/GHC/Iface/Decl.hs
@@ -13,7 +13,6 @@
module GHC.Iface.Decl
( coAxiomToIfaceDecl
, tyThingToIfaceDecl -- Converting things to their Iface equivalents
- , toIfaceBooleanFormula
)
where
@@ -33,21 +32,17 @@ import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Core.Multiplicity
-
import GHC.Types.Id
import GHC.Types.Var.Env
import GHC.Types.Var
import GHC.Types.Name
import GHC.Types.Basic
import GHC.Types.TyThing
-import GHC.Types.SrcLoc
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Data.Maybe
-import GHC.Data.BooleanFormula
-
import Data.List ( findIndex, mapAccumL )
{-
@@ -287,7 +282,7 @@ classToIfaceDecl env clas
ifClassCtxt = tidyToIfaceContext env1 sc_theta,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
- ifMinDef = toIfaceBooleanFormula $ fmap (mkIfLclName . getOccFS) (classMinimalDef clas)
+ ifMinDef = toIfaceBooleanFormula (classMinimalDef clas)
}
(env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
@@ -335,10 +330,3 @@ tidyTyConBinders = mapAccumL tidyTyConBinder
tidyTyVar :: TidyEnv -> TyVar -> IfLclName
tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
-
-toIfaceBooleanFormula :: BooleanFormula IfLclName -> IfaceBooleanFormula
-toIfaceBooleanFormula = \case
- Var nm -> IfVar nm
- And bfs -> IfAnd (map (toIfaceBooleanFormula . unLoc) bfs)
- Or bfs -> IfOr (map (toIfaceBooleanFormula . unLoc) bfs)
- Parens bf -> IfParens (toIfaceBooleanFormula . unLoc $ bf)
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index e6445f506c4..5c18b8bb873 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -2041,8 +2041,9 @@ instance ToHie PendingRnSplice where
instance ToHie PendingTcSplice where
toHie (PendingTcSplice _ e) = toHie e
-instance ToHie (LBooleanFormula (LocatedN Name)) where
- toHie (L span form) = concatM $ makeNode form (locA span) : case form of
+instance (HiePass p, Data (IdGhcP p))
+ => ToHie (GenLocated SrcSpanAnnL (BooleanFormula (GhcPass p))) where
+ toHie (L span form) = concatM $ makeNode form (locA span) : case form of
Var a ->
[ toHie $ C Use a
]
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index b09dde5e76c..ff374513adb 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -35,10 +35,8 @@ module GHC.Iface.Syntax (
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
ifaceDeclFingerprints,
- fromIfaceBooleanFormula,
fromIfaceWarnings,
fromIfaceWarningTxt,
-
-- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
freeNamesIfConDecls,
@@ -51,7 +49,10 @@ module GHC.Iface.Syntax (
import GHC.Prelude
+import GHC.Builtin.Names(mkUnboundName)
import GHC.Data.FastString
+import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue)
+
import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey,
constraintKindTyConKey )
import GHC.Types.Unique ( hasKey )
@@ -62,9 +63,9 @@ import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Core.Class
import GHC.Types.FieldLabel
-import GHC.Types.Name.Set
import GHC.Core.Coercion.Axiom ( BranchIndex )
import GHC.Types.Name
+import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.CostCentre
import GHC.Types.Literal
@@ -75,7 +76,6 @@ import GHC.Unit.Module
import GHC.Unit.Module.Warnings
import GHC.Types.SrcLoc
import GHC.Types.SourceText
-import GHC.Data.BooleanFormula ( BooleanFormula(..), pprBooleanFormula, isTrue )
import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike )
import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag )
import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
@@ -94,6 +94,8 @@ import GHC.Utils.Panic
import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
seqList, zipWithEqual )
+import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..))
+
import Control.Monad
import System.IO.Unsafe
import Control.DeepSeq
@@ -213,18 +215,14 @@ data IfaceClassBody
ifMinDef :: IfaceBooleanFormula -- Minimal complete definition
}
+-- See also 'BooleanFormula'
data IfaceBooleanFormula
= IfVar IfLclName
| IfAnd [IfaceBooleanFormula]
| IfOr [IfaceBooleanFormula]
| IfParens IfaceBooleanFormula
+ deriving Eq
-fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula IfLclName
-fromIfaceBooleanFormula = \case
- IfVar nm -> Var nm
- IfAnd ibfs -> And (map (noLocA . fromIfaceBooleanFormula) ibfs)
- IfOr ibfs -> Or (map (noLocA . fromIfaceBooleanFormula) ibfs)
- IfParens ibf -> Parens (noLocA . fromIfaceBooleanFormula $ ibf)
data IfaceTyConParent
= IfNoParent
@@ -1039,13 +1037,21 @@ pprIfaceDecl ss (IfaceClass { ifName = clas
| showSub ss sg = Just $ pprIfaceClassOp ss sg
| otherwise = Nothing
- pprMinDef :: BooleanFormula IfLclName -> SDoc
+ pprMinDef :: BooleanFormula GhcRn -> SDoc
pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions
text "{-# MINIMAL" <+>
pprBooleanFormula
- (\_ def -> cparen (isLexSym def) (ppr def)) 0 (fmap ifLclNameFS minDef) <+>
+ (\_ def -> let fs = getOccFS def in cparen (isLexSym fs) (ppr fs)) 0 minDef <+>
text "#-}"
+ fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula GhcRn
+ -- `mkUnboundName` here is fine because the Name generated is only used for pretty printing and nothing else.
+ fromIfaceBooleanFormula (IfVar nm ) = Var $ noLocA . mkUnboundName . mkVarOccFS . ifLclNameFS $ nm
+ fromIfaceBooleanFormula (IfAnd bfs ) = And $ map (noLocA . fromIfaceBooleanFormula) bfs
+ fromIfaceBooleanFormula (IfOr bfs ) = Or $ map (noLocA . fromIfaceBooleanFormula) bfs
+ fromIfaceBooleanFormula (IfParens bf) = Parens $ (noLocA . fromIfaceBooleanFormula) bf
+
+
-- See Note [Suppressing binder signatures] in GHC.Iface.Type
suppress_bndr_sig = SuppressBndrSig True
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 5aa5dc349e7..9d4c35ad7a5 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -32,6 +32,7 @@ module GHC.IfaceToCore (
hydrateCgBreakInfo
) where
+
import GHC.Prelude
import GHC.ByteCode.Types
@@ -43,7 +44,6 @@ import GHC.Driver.Config.Core.Lint ( initLintConfig )
import GHC.Builtin.Types.Literals(typeNatCoAxiomRules)
import GHC.Builtin.Types
-import GHC.Iface.Decl (toIfaceBooleanFormula)
import GHC.Iface.Syntax
import GHC.Iface.Load
import GHC.Iface.Env
@@ -123,20 +123,26 @@ import GHC.Types.Tickish
import GHC.Types.TyThing
import GHC.Types.Error
+import GHC.Parser.Annotation (noLocA)
+
+import GHC.Hs.Extension ( GhcRn )
+
import GHC.Fingerprint
-import qualified GHC.Data.BooleanFormula as BF
import Control.Monad
-import GHC.Parser.Annotation
import GHC.Driver.Env.KnotVars
import GHC.Unit.Module.WholeCoreBindings
import Data.IORef
import Data.Foldable
import Data.Function ( on )
+import Data.List(nub)
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 Language.Haskell.Syntax.BooleanFormula (BooleanFormula)
+import Language.Haskell.Syntax.BooleanFormula qualified as BF(BooleanFormula(..))
import Language.Haskell.Syntax.Extension (NoExtField (NoExtField))
{-
@@ -297,14 +303,38 @@ mergeIfaceDecl d1 d2
plusNameEnv_C mergeIfaceClassOp
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
+
in d1 { ifBody = (ifBody d1) {
ifSigs = ops,
- ifMinDef = toIfaceBooleanFormula . BF.mkOr . map (noLocA . fromIfaceBooleanFormula) $ [bf1, bf2]
+ ifMinDef = mkOr [ bf1, bf2]
}
} `withRolesFrom` d2
-- It doesn't matter; we'll check for consistency later when
-- we merge, see 'mergeSignatures'
| otherwise = d1 `withRolesFrom` d2
+ where
+ -- The reason we need to duplicate mkOr here, instead of
+ -- using BooleanFormula's mkOr and just doing the loop like:
+ -- `toIfaceBooleanFormula . mkOr . fromIfaceBooleanFormula`
+ -- is quite subtle. Say we have the following minimal pragma:
+ -- {-# MINIMAL f | g #-}. If we use fromIfaceBooleanFormula
+ -- first, we will end up doing
+ -- `nub [Var (mkUnboundName f), Var (mkUnboundName g)]`,
+ -- which might seem fine, but Name equallity is decided by
+ -- their Unique, which will be identical since mkUnboundName
+ -- just stuffs the mkUnboundKey unqiue into both.
+ -- So the result will be {-# MINIMAL f #-}, oopsie.
+ -- Duplication it is.
+ mkOr :: [IfaceBooleanFormula] -> IfaceBooleanFormula
+ mkOr = maybe (IfAnd []) (mkOr' . nub . concat) . mapM fromOr
+ where
+ -- See Note [Simplification of BooleanFormulas]
+ fromOr bf = case bf of
+ (IfOr xs) -> Just xs
+ (IfAnd []) -> Nothing
+ _ -> Just [bf]
+ mkOr' [x] = x
+ mkOr' xs = IfOr xs
-- Note [Role merging]
-- ~~~~~~~~~~~~~~~~~~~
@@ -795,8 +825,7 @@ tc_iface_decl _parent ignore_prags
; sigs <- mapM tc_sig rdr_sigs
; fds <- mapM tc_fd rdr_fds
; traceIf (text "tc-iface-class3" <+> ppr tc_name)
- ; let mindef_occ = fromIfaceBooleanFormula if_mindef
- ; mindef <- traverse (lookupIfaceTop . mkVarOccFS . ifLclNameFS) mindef_occ
+ ; mindef <- tc_boolean_formula if_mindef
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_name)
@@ -845,6 +874,12 @@ tc_iface_decl _parent ignore_prags
-- e.g. type AT a; type AT b = AT [b] #8002
return (ATI tc mb_def)
+ tc_boolean_formula :: IfaceBooleanFormula -> IfL (BooleanFormula GhcRn)
+ 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 <$> (lookupIfaceTop . mkVarOccFS . ifLclNameFS $ nm)
+
mk_sc_doc pred = text "Superclass" <+> ppr pred
mk_at_doc tc = text "Associated type" <+> ppr tc
mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index a5c6cb5eae8..1eb58503703 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -39,9 +39,9 @@ module GHC.Parser
where
-- base
-import Control.Monad ( unless, liftM, when, (<=<) )
+import Control.Monad ( unless, liftM, when, (<=<) )
import GHC.Exts
-import Data.Maybe ( maybeToList )
+import Data.Maybe ( maybeToList )
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import qualified Prelude -- for happy-generated code
@@ -3710,27 +3710,27 @@ overloaded_label :: { Located (SourceText, FastString) }
-----------------------------------------------------------------------------
-- Warnings and deprecations
-name_boolformula_opt :: { LBooleanFormula (LocatedN RdrName) }
+name_boolformula_opt :: { LBooleanFormula GhcPs }
: name_boolformula { $1 }
| {- empty -} { noLocA mkTrue }
-name_boolformula :: { LBooleanFormula (LocatedN RdrName) }
- : name_boolformula_and { $1 }
+name_boolformula :: { LBooleanFormula GhcPs }
+ : name_boolformula_and { $1 }
| name_boolformula_and '|' name_boolformula
{% do { h <- addTrailingVbarL $1 (epTok $2)
; return (sLLa $1 $> (Or [h,$3])) } }
-name_boolformula_and :: { LBooleanFormula (LocatedN RdrName) }
+name_boolformula_and :: { LBooleanFormula GhcPs }
: name_boolformula_and_list
{ sLLa (head $1) (last $1) (And ($1)) }
-name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] }
+name_boolformula_and_list :: { [LBooleanFormula GhcPs] }
: name_boolformula_atom { [$1] }
| name_boolformula_atom ',' name_boolformula_and_list
{% do { h <- addTrailingCommaL $1 (epTok $2)
; return (h : $3) } }
-name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) }
+name_boolformula_atom :: { LBooleanFormula GhcPs }
: '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens $2))
(AnnList Nothing (ListParens (epTok $1) (epTok $3)) [] noAnn []) }
| name_var { sL1a $1 (Var $1) }
@@ -4704,4 +4704,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
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 3fef3acac9d..b30eba7c09e 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -80,6 +80,7 @@ import Control.Monad
import Data.List ( partition )
import Data.List.NonEmpty ( NonEmpty(..) )
import GHC.Types.Unique.DSet (mkUniqDSet)
+import GHC.Data.BooleanFormula (bfTraverse)
{-
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
@@ -1137,7 +1138,7 @@ renameSig ctxt (FixSig _ fsig)
; return (FixSig noAnn new_fsig, emptyFVs) }
renameSig ctxt sig@(MinimalSig (_, s) (L l bf))
- = do new_bf <- traverse (lookupSigOccRnN ctxt sig) bf
+ = do new_bf <- bfTraverse (lookupSigOccRnN ctxt sig) bf
return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs)
renameSig ctxt sig@(PatSynSig _ vs ty)
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 91dc69ec8ee..cf68754cb08 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/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 [ noLocA (mkVar name)
+ defMindef = mkAnd [ noLocA (mkVar (noLocA name))
| (name, _, Nothing) <- op_info ]
instantiateMethod :: Class -> TcId -> [TcType] -> TcType
@@ -402,8 +402,8 @@ findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef = firstJusts . map toMinimalDef
where
toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
- toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)
- toMinimalDef _ = Nothing
+ toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just bf
+ toMinimalDef _ = Nothing
{-
Note [Polymorphic methods]
@@ -603,4 +603,4 @@ warnMissingAT name
$ InvalidAssoc $ InvalidAssocInstance
$ AssocInstanceMissing name
; diagnosticTc (warn && hsc_src == HsSrcFile) diag
- }
+ }
\ No newline at end of file
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index ef7999a7232..b88d7240311 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -1889,7 +1889,7 @@ tcMethods skol_info dfun_id clas tyvars dfun_ev_vars inst_tys
--
-- See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors,
-- point (D).
- whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
+ whenIsJust (isUnsatisfied (methodExists . unLoc) (classMinimalDef clas)) $
warnUnsatisfiedMinimalDefinition
methodExists meth = isJust (findMethodBind meth binds prag_fn)
diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs
index 9e3a33bf1b1..58a0f826d4a 100644
--- a/compiler/Language/Haskell/Syntax/Binds.hs
+++ b/compiler/Language/Haskell/Syntax/Binds.hs
@@ -26,15 +26,13 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr
( LHsExpr
, MatchGroup
, GRHSs )
-import {-# SOURCE #-} Language.Haskell.Syntax.Pat
- ( LPat )
-
+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 )
import GHC.Types.Basic (InlinePragma)
-import GHC.Data.BooleanFormula (LBooleanFormula)
import GHC.Types.SourceText (StringLiteral)
import Data.Void
@@ -379,7 +377,7 @@ data Sig pass
-- | A minimal complete definition pragma
--
-- > {-# MINIMAL a | (b, c | (d | e)) #-}
- | MinimalSig (XMinimalSig pass) (LBooleanFormula (LIdP pass))
+ | MinimalSig (XMinimalSig pass) (LBooleanFormula pass)
-- | A "set cost centre" pragma for declarations
--
diff --git a/compiler/Language/Haskell/Syntax/BooleanFormula.hs b/compiler/Language/Haskell/Syntax/BooleanFormula.hs
new file mode 100644
index 00000000000..0ef80e444b5
--- /dev/null
+++ b/compiler/Language/Haskell/Syntax/BooleanFormula.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+
+module Language.Haskell.Syntax.BooleanFormula(
+ BooleanFormula(..), LBooleanFormula,
+ mkVar, mkFalse, mkTrue, mkBool, mkAnd, mkOr
+ ) where
+
+import Prelude hiding ( init, last )
+import Data.List ( nub )
+import Language.Haskell.Syntax.Extension (XRec, UnXRec (..), LIdP)
+
+
+-- types
+type LBooleanFormula p = XRec p (BooleanFormula p)
+data BooleanFormula p = Var (LIdP p) | And [LBooleanFormula p] | Or [LBooleanFormula p]
+ | Parens (LBooleanFormula p)
+
+-- instances
+deriving instance (Eq (LIdP p), Eq (LBooleanFormula p)) => Eq (BooleanFormula p)
+
+-- smart constructors
+-- see note [Simplification of BooleanFormulas]
+mkVar :: LIdP p -> BooleanFormula p
+mkVar = Var
+
+mkFalse, mkTrue :: BooleanFormula p
+mkFalse = Or []
+mkTrue = And []
+
+-- Convert a Bool to a BooleanFormula
+mkBool :: Bool -> BooleanFormula p
+mkBool False = mkFalse
+mkBool True = mkTrue
+
+-- Make a conjunction, and try to simplify
+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 :: 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] = unXRec @p x
+ mkAnd' xs = And xs
+
+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 unXRec @p bf of
+ (Or xs) -> Just xs
+ (And []) -> Nothing
+ _ -> Just [bf]
+ mkOr' [x] = unXRec @p x
+ mkOr' xs = Or xs
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 342cacfd5a8..0da2168c192 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -993,6 +993,7 @@ Library
Language.Haskell.Syntax
Language.Haskell.Syntax.Basic
Language.Haskell.Syntax.Binds
+ Language.Haskell.Syntax.BooleanFormula
Language.Haskell.Syntax.Decls
Language.Haskell.Syntax.Expr
Language.Haskell.Syntax.Extension
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index f134a6f6cc1..15d4270e36c 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -234,6 +234,7 @@ GHC.Utils.Word64
Language.Haskell.Syntax
Language.Haskell.Syntax.Basic
Language.Haskell.Syntax.Binds
+Language.Haskell.Syntax.BooleanFormula
Language.Haskell.Syntax.Decls
Language.Haskell.Syntax.Expr
Language.Haskell.Syntax.Extension
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index e326eb7752e..0010fce1573 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -258,6 +258,7 @@ GHC.Utils.Word64
Language.Haskell.Syntax
Language.Haskell.Syntax.Basic
Language.Haskell.Syntax.Binds
+Language.Haskell.Syntax.BooleanFormula
Language.Haskell.Syntax.Decls
Language.Haskell.Syntax.Expr
Language.Haskell.Syntax.Extension
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index ddca9dbb146..b7949dd2685 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -2807,7 +2807,7 @@ instance ExactPrint (AnnDecl GhcPs) where
-- ---------------------------------------------------------------------
-instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where
+instance ExactPrint (BF.BooleanFormula GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
@@ -4527,7 +4527,7 @@ instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where
(an', fs') <- markAnnList an (markAnnotated fs)
return (L an' fs')
-instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where
+instance ExactPrint (LocatedL (BF.BooleanFormula GhcPs)) where
getAnnotationEntry = entryFromLocatedA
setAnnotationAnchor = setAnchorAn
exact (L an bf) = do
diff --git a/utils/haddock/haddock-api/src/Haddock/Convert.hs b/utils/haddock/haddock-api/src/Haddock/Convert.hs
index 4034d49af45..df88c753281 100644
--- a/utils/haddock/haddock-api/src/Haddock/Convert.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Convert.hs
@@ -45,6 +45,7 @@ import GHC.Builtin.Types
, promotedNilDataCon
, unitTy
)
+
import GHC.Builtin.Types.Prim (alphaTyVars)
import GHC.Core.Class
import GHC.Core.Coercion.Axiom
@@ -176,7 +177,7 @@ tyThingToLHsDecl prr t = case t of
$ snd
$ classTvsFds cl
, tcdSigs =
- noLocA (MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA $ classMinimalDef cl)
+ noLocA (MinimalSig (noAnn, NoSourceText) . noLocA $ classMinimalDef cl)
: [ noLocA tcdSig
| clsOp <- classOpItems cl
, tcdSig <- synifyTcIdSig vs clsOp
diff --git a/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs b/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
index da50807b235..5a5994cdcc8 100644
--- a/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
@@ -19,6 +19,8 @@
-- Portability : portable
module Haddock.Interface.Rename (renameInterface) where
+import Prelude hiding (mapM)
+
import Control.Applicative ()
import Control.DeepSeq (force)
import Control.Monad hiding (mapM)
@@ -28,12 +30,13 @@ import Data.Foldable (traverse_)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Traversable (mapM)
+
import GHC hiding (NoLink)
import GHC.Builtin.Types (eqTyCon_RDR, tupleDataConName, tupleTyConName)
import GHC.Types.Basic (Boxity (..), TopLevelFlag (..), TupleSort (..))
import GHC.Types.Name
import GHC.Types.Name.Reader (RdrName (Exact))
-import Prelude hiding (mapM)
+import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..))
import Haddock.Backends.Hoogle (ppExportD)
import Haddock.GhcUtils
@@ -770,11 +773,22 @@ renameSig sig = case sig of
lnames' <- mapM renameNameL lnames
return $ FixSig noExtField (FixitySig noExtField lnames' fixity)
MinimalSig _ (L l s) -> do
- s' <- traverse (traverse lookupRn) s
+ s' <- bfTraverse (traverse lookupRn) s
return $ MinimalSig noExtField (L l s')
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
+bfTraverse :: Applicative f
+ => (LIdP (GhcPass p) -> f (LIdP DocNameI))
+ -> BooleanFormula (GhcPass p)
+ -> f (BooleanFormula DocNameI)
+bfTraverse f = go
+ where
+ go (Var a ) = Var <$> f a
+ 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
lname' <- renameNameL lname
diff --git a/utils/haddock/haddock-api/src/Haddock/Types.hs b/utils/haddock/haddock-api/src/Haddock/Types.hs
index 9492b29b890..b8191d83310 100644
--- a/utils/haddock/haddock-api/src/Haddock/Types.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Types.hs
@@ -53,6 +53,7 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import GHC
import qualified GHC.Data.Strict as Strict
+import GHC.Data.BooleanFormula (BooleanFormula)
import GHC.Driver.Session (Language)
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.InstEnv (is_dfun_name)
@@ -819,6 +820,7 @@ type instance Anno (HsDecl DocNameI) = SrcSpanAnnA
type instance Anno (FamilyResultSig DocNameI) = EpAnn NoEpAnns
type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA
type instance Anno (HsSigType DocNameI) = SrcSpanAnnA
+type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnL
type XRecCond a =
( XParTy a ~ (EpToken "(", EpToken ")")
--
GitLab