[Git][ghc/ghc][wip/ttg-booleanformula] parameterize booleanformula over the pass and try to get everything to compile.
Hassan Al-Awwadi (@hassan.awwadi)
gitlab at gitlab.haskell.org
Sat Sep 28 11:59:12 UTC 2024
Hassan Al-Awwadi pushed to branch wip/ttg-booleanformula at Glasgow Haskell Compiler / GHC
Commits:
1cb56a31 by Hassan Al-Awwadi at 2024-09-28T13:58:38+02:00
parameterize booleanformula over the pass and try to get everything to compile.
Started as BooleanFormula a
now BooleanFormula p a
next step if possible: BooleanFormula p.
blocker to figur eout: BooeleanFormula p IfLclName in GHC/Iface/Type.hs. IfLclName wraps faststring, seemingly, and can't figure out how to convert this.
- - - - -
17 changed files:
- compiler/GHC/Core/Class.hs
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser.y
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- + compiler/Language/Haskell/Syntax/BooleanFormula.hs
- compiler/ghc.cabal.in
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
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
@@ -135,7 +136,7 @@ data TyFamEqnValidityInfo
-- Note [Type-checking default assoc decls] in GHC.Tc.TyCl.
}
-type ClassMinimalDef = BooleanFormula Name -- Required methods
+type ClassMinimalDef = BooleanFormula GhcRn Name -- Required methods
data ClassBody
= AbstractClass
=====================================
compiler/GHC/Data/BooleanFormula.hs
=====================================
@@ -1,5 +1,5 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveTraversable #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE TypeFamilies #-}
--------------------------------------------------------------------------------
-- | Boolean formulas without quantifiers and without negation.
@@ -8,73 +8,78 @@
-- 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,
+ bfSwitchPass, lbfSwitchPass,
isFalse, isTrue,
eval, simplify, isUnsatisfied,
implies, impliesAtom,
pprBooleanFormula, pprBooleanFormulaNice
) 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 (GenLocated(L), unLoc)
+import GHC.Utils.Outputable
+import GHC.Parser.Annotation ( SrcSpanAnnL )
+import GHC.Hs.Extension (GhcPass)
+import Language.Haskell.Syntax.Extension (Anno)
+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
-
-mkFalse, mkTrue :: BooleanFormula a
-mkFalse = Or []
-mkTrue = And []
-
--- 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
- 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
- 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
+-- Actually should this be moved to GHC.Hs.Decls?
+-- That's where most of the anno instances are, anyway.
+-- But I don't know how strictly that is just an implementation detail
+-- I'm allowed to ignore?
+type instance Anno (BooleanFormula (GhcPass p) a) = SrcSpanAnnL
+
+-- In a perfect world I could do something like
+-- instance (Functor (LBooleanFormula p) => Functor (BooleanFormula p)).
+-- But type synonyms need to be fully applied, and I could not figure out the
+-- correct way to hack my way around wrapping and unwrapping and ~ to make it work
+-- less cleanly. My last hope for using mapXRec also doe not work, because it has
+-- the Anno p a ~ Anno p b constraint which seems impossible to get in the class
+-- constraint header.
+instance Functor (BooleanFormula (GhcPass p)) where
+ fmap :: (a -> b) -> BooleanFormula (GhcPass p) a -> BooleanFormula (GhcPass p) b
+ fmap f (Var a ) = Var (f a)
+ fmap f (And bfs) = And $ fmap (fmap (fmap f)) bfs
+ fmap f (Or bfs) = Or $ fmap (fmap (fmap f)) bfs
+ fmap f (Parens bf ) = Parens $ fmap (fmap f) bf
+
+-- See comment above Functor instance.
+instance Traversable (BooleanFormula (GhcPass p)) where
+ sequenceA :: Applicative f => BooleanFormula (GhcPass p) (f a) -> f (BooleanFormula (GhcPass p) a)
+ sequenceA (Var a) = Var <$> a
+ sequenceA (And bfs) = And <$> traverse (traverse sequenceA) bfs
+ sequenceA (Or bfs) = Or <$> traverse (traverse sequenceA) bfs
+ sequenceA (Parens bf ) = Parens <$> traverse sequenceA bf
+
+-- Just putting this comment here to say I have no idea if this is the right
+-- design choice. The alterantive is to just coerce", somehow.
+-- When I tried that I got hit with the "Couldn't match type ‘Parsed’ with ‘Renamed’"...
+bfSwitchPass :: forall p p' l a
+ . (LBooleanFormula p a ~ GenLocated l (BooleanFormula p a)
+ , LBooleanFormula p' a ~ GenLocated l (BooleanFormula p' a))
+ => BooleanFormula p a -> BooleanFormula p' a
+bfSwitchPass (Var a ) = Var a
+bfSwitchPass (And bfs) = And $ fmap lbfSwitchPass bfs
+bfSwitchPass (Or bfs) = Or $ fmap lbfSwitchPass bfs
+bfSwitchPass (Parens bf ) = Parens $ lbfSwitchPass bf
+
+lbfSwitchPass :: forall p p' l a
+ . (LBooleanFormula p a ~ GenLocated l (BooleanFormula p a)
+ , LBooleanFormula p' a ~ GenLocated l (BooleanFormula p' a))
+ => LBooleanFormula p a
+ -> LBooleanFormula p' a
+lbfSwitchPass (L loc bf) = L loc (bfSwitchPass bf)
{-
@@ -115,15 +120,15 @@ We don't show a ridiculous error message like
-- Evaluation and simplification
----------------------------------------------------------------------
-isFalse :: BooleanFormula a -> Bool
+isFalse :: BooleanFormula (GhcPass p) a -> Bool
isFalse (Or []) = True
isFalse _ = False
-isTrue :: BooleanFormula a -> Bool
+isTrue :: BooleanFormula (GhcPass p) a -> Bool
isTrue (And []) = True
isTrue _ = False
-eval :: (a -> Bool) -> BooleanFormula a -> Bool
+eval :: (a -> Bool) -> BooleanFormula (GhcPass p) a -> 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 +136,18 @@ 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 :: Eq a => (a -> Maybe Bool) -> BooleanFormula (GhcPass p) a -> BooleanFormula (GhcPass p) a
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 a => (a -> Bool) -> BooleanFormula (GhcPass p) a -> Maybe (BooleanFormula (GhcPass p) a)
isUnsatisfied f bf
| isTrue bf' = Nothing
| otherwise = Just bf'
@@ -155,17 +160,17 @@ 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
+impliesAtom :: Eq a => BooleanFormula (GhcPass p) a -> a -> Bool
Var x `impliesAtom` y = x == y
-And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs
+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 a => BooleanFormula (GhcPass p) a -> BooleanFormula (GhcPass p) a -> Bool
implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2])
where
- go :: Uniquable a => Clause a -> Clause a -> Bool
+ go :: Uniquable a => Clause (GhcPass p) a -> Clause (GhcPass p) a -> Bool
go l at Clause{ clauseExprs = hyp:hyps } r =
case hyp of
Var x | memberClauseAtoms x r -> True
@@ -183,14 +188,14 @@ implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2])
go _ _ = False
-- A small sequent calculus proof engine.
-data Clause a = Clause {
+data Clause p a = Clause {
clauseAtoms :: UniqSet a,
- clauseExprs :: [BooleanFormula a]
+ clauseExprs :: [BooleanFormula p a]
}
-extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a
+extendClauseAtoms :: Uniquable a => Clause p a -> a -> Clause p a
extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x }
-memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool
+memberClauseAtoms :: Uniquable a => a -> Clause p a -> Bool
memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c
----------------------------------------------------------------------
@@ -199,28 +204,28 @@ 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 -> a -> SDoc)
+ -> (Rational -> [SDoc] -> SDoc)
+ -> (Rational -> [SDoc] -> SDoc)
+ -> Rational -> BooleanFormula (GhcPass p) a -> 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 -> a -> SDoc) -> Rational -> BooleanFormula (GhcPass p) a -> 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 a => BooleanFormula (GhcPass p) a -> SDoc
pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0
where
pprVar _ = quotes . ppr
@@ -230,11 +235,10 @@ 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 (OutputableBndr a) => Outputable (BooleanFormula (GhcPass p) a) where
ppr = pprBooleanFormulaNormal
-pprBooleanFormulaNormal :: (OutputableBndr a)
- => BooleanFormula a -> SDoc
+pprBooleanFormulaNormal :: (OutputableBndr a) => BooleanFormula (GhcPass p) a -> SDoc
pprBooleanFormulaNormal = go
where
go (Var x) = pprPrefixOcc x
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -935,7 +935,7 @@ instance Outputable TcSpecPrag where
= text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl
pprMinimalSig :: (OutputableBndr name)
- => LBooleanFormula (GenLocated l name) -> SDoc
+ => LBooleanFormula (GhcPass p) (GenLocated l name) -> SDoc
pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
{-
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -103,6 +103,8 @@ module GHC.Hs.Decls (
import GHC.Prelude
import Language.Haskell.Syntax.Decls
+import Language.Haskell.Syntax.Extension
+import Language.Haskell.Syntax.BooleanFormula (BooleanFormula)
import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice )
-- Because Expr imports Decls via HsBracket
@@ -112,7 +114,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
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -33,6 +33,7 @@ import GHC.Hs.Type
import GHC.Hs.Pat
import GHC.Hs.ImpExp
import GHC.Parser.Annotation
+import GHC.Data.BooleanFormula (BooleanFormula(..))
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs-----------------------------------------
@@ -584,3 +585,9 @@ deriving instance Data XXPatGhcTc
deriving instance Data XViaStrategyPs
-- ---------------------------------------------------------------------
+
+deriving instance Data a => Data (BooleanFormula GhcPs a)
+deriving instance Data a => Data (BooleanFormula GhcRn a)
+deriving instance Data a => Data (BooleanFormula GhcTc a)
+
+---------------------------------------------------------------------
\ No newline at end of file
=====================================
compiler/GHC/Iface/Decl.hs
=====================================
@@ -33,7 +33,7 @@ import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Core.Multiplicity
-
+import GHC.Hs.Extension ( GhcPass )
import GHC.Types.Id
import GHC.Types.Var.Env
import GHC.Types.Var
@@ -336,7 +336,7 @@ tidyTyConBinders = mapAccumL tidyTyConBinder
tidyTyVar :: TidyEnv -> TyVar -> IfLclName
tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
-toIfaceBooleanFormula :: BooleanFormula IfLclName -> IfaceBooleanFormula
+toIfaceBooleanFormula :: BooleanFormula (GhcPass p) IfLclName -> IfaceBooleanFormula
toIfaceBooleanFormula = \case
Var nm -> IfVar nm
And bfs -> IfAnd (map (toIfaceBooleanFormula . unLoc) bfs)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -2014,7 +2014,7 @@ instance ToHie PendingRnSplice where
instance ToHie PendingTcSplice where
toHie (PendingTcSplice _ e) = toHie e
-instance ToHie (LBooleanFormula (LocatedN Name)) where
+instance Typeable p => ToHie (GenLocated SrcSpanAnnL (BooleanFormula (GhcPass p) (LocatedN Name))) where
toHie (L span form) = concatM $ makeNode form (locA span) : case form of
Var a ->
[ toHie $ C Use a
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -82,7 +82,7 @@ import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
import GHC.Builtin.Types ( constraintKindTyConName )
import GHC.Stg.InferTags.TagSig
import GHC.Parser.Annotation (noLocA)
-import GHC.Hs.Extension ( GhcRn )
+import GHC.Hs.Extension ( GhcRn, GhcPass )
import GHC.Hs.Doc ( WithHsDocIdentifiers(..) )
import GHC.Utils.Lexeme (isLexSym)
@@ -219,7 +219,7 @@ data IfaceBooleanFormula
| IfOr [IfaceBooleanFormula]
| IfParens IfaceBooleanFormula
-fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula IfLclName
+fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula (GhcPass p) IfLclName
fromIfaceBooleanFormula = \case
IfVar nm -> Var nm
IfAnd ibfs -> And (map (noLocA . fromIfaceBooleanFormula) ibfs)
@@ -1039,7 +1039,7 @@ pprIfaceDecl ss (IfaceClass { ifName = clas
| showSub ss sg = Just $ pprIfaceClassOp ss sg
| otherwise = Nothing
- pprMinDef :: BooleanFormula IfLclName -> SDoc
+ pprMinDef :: BooleanFormula (GhcPass p) IfLclName -> SDoc
pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions
text "{-# MINIMAL" <+>
pprBooleanFormula
=====================================
compiler/GHC/Parser.y
=====================================
@@ -39,14 +39,15 @@ 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
import GHC.Hs
+import GHC.Hs.Extension (GhcPass, Pass(..))
import GHC.Driver.Backpack.Syntax
@@ -3680,27 +3681,27 @@ overloaded_label :: { Located (SourceText, FastString) }
-----------------------------------------------------------------------------
-- Warnings and deprecations
-name_boolformula_opt :: { LBooleanFormula (LocatedN RdrName) }
+name_boolformula_opt :: { LBooleanFormula GhcPs (LocatedN RdrName) }
: name_boolformula { $1 }
| {- empty -} { noLocA mkTrue }
-name_boolformula :: { LBooleanFormula (LocatedN RdrName) }
+name_boolformula :: { LBooleanFormula GhcPs (LocatedN RdrName) }
: name_boolformula_and { $1 }
| name_boolformula_and '|' name_boolformula
{% do { h <- addTrailingVbarL $1 (gl $2)
; return (sLLa $1 $> (Or [h,$3])) } }
-name_boolformula_and :: { LBooleanFormula (LocatedN RdrName) }
+name_boolformula_and :: { LBooleanFormula GhcPs (LocatedN RdrName) }
: name_boolformula_and_list
{ sLLa (head $1) (last $1) (And ($1)) }
-name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] }
+name_boolformula_and_list :: { [LBooleanFormula GhcPs (LocatedN RdrName)] }
: name_boolformula_atom { [$1] }
| name_boolformula_atom ',' name_boolformula_and_list
{% do { h <- addTrailingCommaL $1 (gl $2)
; return (h : $3) } }
-name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) }
+name_boolformula_atom :: { LBooleanFormula GhcPs (LocatedN RdrName) }
: '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens $2))
(AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) }
| name_var { sL1a $1 (Var $1) }
=====================================
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 (bfSwitchPass)
{-
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
@@ -1138,7 +1139,7 @@ renameSig ctxt (FixSig _ fsig)
renameSig ctxt sig@(MinimalSig (_, s) (L l bf))
= do new_bf <- traverse (lookupSigOccRnN ctxt sig) bf
- return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs)
+ return (MinimalSig (noAnn, s) (L l (bfSwitchPass new_bf)), emptyFVs)
renameSig ctxt sig@(PatSynSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs
=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -402,7 +402,7 @@ 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 (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc (bfSwitchPass bf))
toMinimalDef _ = Nothing
{-
=====================================
compiler/Language/Haskell/Syntax/Binds.hs
=====================================
@@ -28,6 +28,7 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr
, GRHSs )
import {-# SOURCE #-} Language.Haskell.Syntax.Pat
( LPat )
+import Language.Haskell.Syntax.BooleanFormula (LBooleanFormula)
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Type
@@ -35,7 +36,6 @@ import Language.Haskell.Syntax.Type
import GHC.Types.Fixity (Fixity)
import GHC.Types.Basic (InlinePragma)
-import GHC.Data.BooleanFormula (LBooleanFormula)
import GHC.Types.SourceText (StringLiteral)
import Data.Void
@@ -465,7 +465,7 @@ data Sig pass
-- 'GHC.Parser.Annotation.AnnClose'
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
- | MinimalSig (XMinimalSig pass) (LBooleanFormula (LIdP pass))
+ | MinimalSig (XMinimalSig pass) (LBooleanFormula pass (LIdP pass))
-- | A "set cost centre" pragma for declarations
--
=====================================
compiler/Language/Haskell/Syntax/BooleanFormula.hs
=====================================
@@ -0,0 +1,68 @@
+{-# 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 (..))
+
+
+
+type LBooleanFormula p a = XRec p (BooleanFormula p a)
+
+--type role BooleanFormula phantom nominal
+data BooleanFormula p a = Var a | And [LBooleanFormula p a] | Or [LBooleanFormula p a]
+ | Parens (LBooleanFormula p a)
+
+-- instances
+deriving instance (Eq a, Eq (LBooleanFormula p a)) => Eq (BooleanFormula p a)
+instance UnXRec p => Foldable (BooleanFormula p) where
+ foldMap :: Monoid m => (a -> m) -> BooleanFormula p a -> m
+ foldMap f (Var a ) = f a
+ foldMap f (And bfs) = foldMap (foldMap f . unXRec @p) bfs
+ foldMap f (Or bfs) = foldMap (foldMap f . unXRec @p) bfs
+ foldMap f (Parens bf ) = foldMap f $ unXRec @p bf
+
+
+mkVar :: a -> BooleanFormula p a
+mkVar = Var
+
+mkFalse, mkTrue :: BooleanFormula p a
+mkFalse = Or []
+mkTrue = And []
+
+-- Convert a Bool to a BooleanFormula
+mkBool :: Bool -> BooleanFormula p a
+mkBool False = mkFalse
+mkBool True = mkTrue
+
+-- Make a conjunction, and try to simplify
+mkAnd :: forall p a. (UnXRec p, Eq a, Eq (LBooleanFormula p a)) => [LBooleanFormula p a] -> BooleanFormula p a
+mkAnd = maybe mkFalse (mkAnd' . nub . concat) . mapM fromAnd
+ where
+ -- See Note [Simplification of BooleanFormulas]
+ fromAnd :: LBooleanFormula p a -> Maybe [LBooleanFormula p a]
+ 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 a. (UnXRec p, Eq a, Eq (LBooleanFormula p a)) => [LBooleanFormula p a] -> BooleanFormula p a
+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
=====================================
compiler/ghc.cabal.in
=====================================
@@ -984,6 +984,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
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -45,6 +45,8 @@ import GHC.Builtin.Types
, promotedNilDataCon
, unitTy
)
+
+import GHC.Data.BooleanFormula(bfSwitchPass)
import GHC.Builtin.Types.Prim (alphaTyVars)
import GHC.Core.Class
import GHC.Core.Coercion.Axiom
@@ -174,7 +176,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 . bfSwitchPass . fmap noLocA $ classMinimalDef cl)
: [ noLocA tcdSig
| clsOp <- classOpItems cl
, tcdSig <- synifyTcIdSig vs clsOp
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -30,6 +30,7 @@ import qualified Data.Set as Set
import Data.Traversable (mapM)
import GHC hiding (NoLink)
import GHC.Builtin.Types (eqTyCon_RDR, tupleDataConName, tupleTyConName)
+import GHC.Data.BooleanFormula (bfSwitchPass)
import GHC.Types.Basic (Boxity (..), TopLevelFlag (..), TupleSort (..))
import GHC.Types.Name
import GHC.Types.Name.Reader (RdrName (Exact))
@@ -768,7 +769,7 @@ renameSig sig = case sig of
return $ FixSig noExtField (FixitySig noExtField lnames' fixity)
MinimalSig _ (L l s) -> do
s' <- traverse (traverse lookupRn) s
- return $ MinimalSig noExtField (L l s')
+ return $ MinimalSig noExtField (L l (bfSwitchPass s'))
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -52,6 +52,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)
@@ -818,6 +819,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 a) = SrcSpanAnnL
type XRecCond a =
( XParTy a ~ AnnParen
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1cb56a311d9d1bfb6b53780e11745911ebf635e4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1cb56a311d9d1bfb6b53780e11745911ebf635e4
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/20240928/e9b45433/attachment-0001.html>
More information about the ghc-commits
mailing list