[Git][ghc/ghc][wip/ttg-booleanformula] 3 commits: ci: RISCV64 cross-compile testing
Hassan Al-Awwadi (@hassan.awwadi)
gitlab at gitlab.haskell.org
Wed Oct 9 10:19:39 UTC 2024
Hassan Al-Awwadi pushed to branch wip/ttg-booleanformula at Glasgow Haskell Compiler / GHC
Commits:
a1ecc826 by Sven Tennie at 2024-10-08T13:36:03-04:00
ci: RISCV64 cross-compile testing
This adds a validation job which tests that we can build a riscv64 cross
compiler and build a simple program using it. We do not currently run
the whole testsuite.
Towards #25254
Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com>
- - - - -
d5c2577f by Arnaud Spiwack at 2024-10-08T13:36:44-04:00
Remove unused accumulators in partition_errors
- - - - -
bca81cf0 by Hassan Al-Awwadi at 2024-10-09T10:19:14+00:00
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, and we parameterized it over the ghcPass instead
of over some arbitrary type.
That said the changes are largely superficial. Most effort was in dealing
with IFaceBooleanFormula, as we used to map the booleanformula to contain a
IfLclName and then transform it to to the IFaceBooleanFormula, but that's
no longer posssible in the current setup. Instead we just folded the
transformation from a Name to an IfLclName in the transformation
from BooleanFormula to IfaceBooleanFormula.
- - - - -
25 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- 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/IfaceToCore.hs
- compiler/GHC/Parser.y
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- + compiler/Language/Haskell/Syntax/BooleanFormula.hs
- compiler/ghc.cabal.in
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- utils/check-exact/ExactPrint.hs
- 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:
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -106,6 +106,7 @@ data Opsys
data LinuxDistro
= Debian12
+ | Debian12Riscv
| Debian11
| Debian11Js
| Debian10
@@ -303,6 +304,7 @@ distroName :: LinuxDistro -> String
distroName Debian12 = "deb12"
distroName Debian11 = "deb11"
distroName Debian11Js = "deb11-emsdk-closure"
+distroName Debian12Riscv = "deb12-riscv"
distroName Debian10 = "deb10"
distroName Debian9 = "deb9"
distroName Fedora33 = "fedora33"
@@ -626,6 +628,7 @@ data ValidateRule =
FullCI -- ^ Run this job when the "full-ci" label is present.
| LLVMBackend -- ^ Run this job when the "LLVM backend" label is present
| JSBackend -- ^ Run this job when the "javascript" label is present
+ | RiscV -- ^ Run this job when the "RISC-V" label is present
| WasmBackend -- ^ Run this job when the "wasm" label is present
| FreeBSDLabel -- ^ Run this job when the "FreeBSD" label is set.
| NonmovingGc -- ^ Run this job when the "non-moving GC" label is set.
@@ -674,6 +677,7 @@ validateRuleString FullCI = or_all ([ labelString "full-ci"
validateRuleString LLVMBackend = labelString "LLVM backend"
validateRuleString JSBackend = labelString "javascript"
+validateRuleString RiscV = labelString "RISC-V"
validateRuleString WasmBackend = labelString "wasm"
validateRuleString FreeBSDLabel = labelString "FreeBSD"
validateRuleString NonmovingGc = labelString "non-moving GC"
@@ -1125,6 +1129,9 @@ cross_jobs = [
-- x86 -> aarch64
validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing)
+ -- x86_64 -> riscv
+ , addValidateRule RiscV (validateBuilds Amd64 (Linux Debian12Riscv) (crossConfig "riscv64-linux-gnu" (Emulator "qemu-riscv64 -L /usr/riscv64-linux-gnu") Nothing))
+
-- Javascript
, addValidateRule JSBackend (validateBuilds Amd64 (Linux Debian11Js) javascriptConfig)
=====================================
.gitlab/jobs.yaml
=====================================
@@ -1854,6 +1854,71 @@
"XZ_OPT": "-9"
}
},
+ "nightly-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh save_test_output",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "8 weeks",
+ "paths": [
+ "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate.tar.xz",
+ "junit.xml",
+ "unexpected-test-output.tar.gz"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "x86_64-linux-deb12-riscv-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12-riscv:$DOCKER_REV",
+ "needs": [
+ {
+ "artifacts": false,
+ "job": "hadrian-ghc-in-ghci"
+ }
+ ],
+ "rules": [
+ {
+ "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)",
+ "when": "on_success"
+ }
+ ],
+ "script": [
+ "sudo chown ghc:ghc -R .",
+ ".gitlab/ci.sh setup",
+ ".gitlab/ci.sh configure",
+ ".gitlab/ci.sh build_hadrian",
+ ".gitlab/ci.sh test_hadrian"
+ ],
+ "stage": "full-build",
+ "tags": [
+ "x86_64-linux"
+ ],
+ "variables": {
+ "BIGNUM_BACKEND": "gmp",
+ "BIN_DIST_NAME": "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate",
+ "BUILD_FLAVOUR": "validate",
+ "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check",
+ "CROSS_EMULATOR": "qemu-riscv64 -L /usr/riscv64-linux-gnu",
+ "CROSS_TARGET": "riscv64-linux-gnu",
+ "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
+ "RUNTEST_ARGS": "",
+ "TEST_ENV": "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate",
+ "XZ_OPT": "-9"
+ }
+ },
"nightly-x86_64-linux-deb12-unreg-validate": {
"after_script": [
".gitlab/ci.sh save_cache",
@@ -5348,6 +5413,70 @@
"TEST_ENV": "x86_64-linux-deb12-numa-slow-validate"
}
},
+ "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh save_test_output",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "2 weeks",
+ "paths": [
+ "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate.tar.xz",
+ "junit.xml",
+ "unexpected-test-output.tar.gz"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "x86_64-linux-deb12-riscv-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12-riscv:$DOCKER_REV",
+ "needs": [
+ {
+ "artifacts": false,
+ "job": "hadrian-ghc-in-ghci"
+ }
+ ],
+ "rules": [
+ {
+ "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*RISC-V.*/)) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
+ "when": "on_success"
+ }
+ ],
+ "script": [
+ "sudo chown ghc:ghc -R .",
+ ".gitlab/ci.sh setup",
+ ".gitlab/ci.sh configure",
+ ".gitlab/ci.sh build_hadrian",
+ ".gitlab/ci.sh test_hadrian"
+ ],
+ "stage": "full-build",
+ "tags": [
+ "x86_64-linux"
+ ],
+ "variables": {
+ "BIGNUM_BACKEND": "gmp",
+ "BIN_DIST_NAME": "ghc-x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate",
+ "BUILD_FLAVOUR": "validate",
+ "CONFIGURE_ARGS": "--with-intree-gmp --enable-strict-ghc-toolchain-check",
+ "CROSS_EMULATOR": "qemu-riscv64 -L /usr/riscv64-linux-gnu",
+ "CROSS_TARGET": "riscv64-linux-gnu",
+ "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
+ "RUNTEST_ARGS": "",
+ "TEST_ENV": "x86_64-linux-deb12-riscv-cross_riscv64-linux-gnu-validate"
+ }
+ },
"x86_64-linux-deb12-unreg-validate": {
"after_script": [
".gitlab/ci.sh save_cache",
=====================================
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 -- 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,74 +8,45 @@
-- 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 (..), GhcPs, GhcRn, 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)
+type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnL
-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
+-- the other part of jury rigging some fake instances for booleanformula
+-- using the genlocated instances of Functor and Traversable.
+bfMap :: (LIdP (GhcPass p) -> LIdP (GhcPass p'))
+ -> BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p')
+bfMap f = bfExplMap fmap f
+bfTraverse :: Applicative f
+ => (LIdP (GhcPass p) -> f (LIdP (GhcPass p')))
+ -> BooleanFormula (GhcPass p)
+ -> f (BooleanFormula (GhcPass p'))
+bfTraverse f = bfExplTraverse traverse f
{-
Note [Simplification of BooleanFormulas]
@@ -115,15 +86,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 +102,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 +132,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 at 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 at 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 +176,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,14 +208,15 @@ 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 Outputable (BooleanFormula GhcPs) where
+ ppr = pprBooleanFormulaNormal
+instance Outputable (BooleanFormula GhcRn) 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)
=====================================
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.Reader
import GHC.Types.Name
@@ -934,9 +934,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
{-
************************************************************************
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -103,6 +103,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
@@ -112,7 +113,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,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-----------------------------------------
@@ -594,3 +596,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
=====================================
compiler/GHC/Iface/Decl.hs
=====================================
@@ -14,6 +14,10 @@ module GHC.Iface.Decl
( coAxiomToIfaceDecl
, tyThingToIfaceDecl -- Converting things to their Iface equivalents
, toIfaceBooleanFormula
+
+ -- converting back
+ , fromIfaceBooleanFormula
+ , traverseIfaceBooleanFormula
)
where
@@ -33,7 +37,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
@@ -42,6 +46,8 @@ import GHC.Types.Basic
import GHC.Types.TyThing
import GHC.Types.SrcLoc
+import GHC.Parser.Annotation (noLocA)
+
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
@@ -49,6 +55,7 @@ import GHC.Data.Maybe
import GHC.Data.BooleanFormula
import Data.List ( findIndex, mapAccumL )
+import Language.Haskell.Syntax.Extension (LIdP)
{-
************************************************************************
@@ -287,7 +294,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 (mkIfLclName . getOccFS . unLoc) (classMinimalDef clas)
}
(env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
@@ -336,9 +343,29 @@ 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)
+toIfaceBooleanFormula :: (LIdP (GhcPass p) -> IfLclName) -> BooleanFormula (GhcPass p) -> IfaceBooleanFormula
+toIfaceBooleanFormula f = go
+ where
+ go (Var nm ) = IfVar (f nm)
+ go (And bfs ) = IfAnd (map (go . unLoc) bfs)
+ go (Or bfs ) = IfOr (map (go . unLoc) bfs)
+ go (Parens bf) = IfParens (go . unLoc $ bf)
+
+fromIfaceBooleanFormula :: (IfLclName -> LIdP (GhcPass p)) -> IfaceBooleanFormula -> BooleanFormula (GhcPass p)
+fromIfaceBooleanFormula f = go
+ where
+ go (IfVar nm ) = Var $ f nm
+ go (IfAnd ibfs ) = And $ map (noLocA . go) ibfs
+ go (IfOr ibfs ) = Or $ map (noLocA . go) ibfs
+ go (IfParens ibf) = Parens $ (noLocA . go) ibf
+
+traverseIfaceBooleanFormula :: Applicative f
+ => (IfLclName -> f (LIdP (GhcPass p)))
+ -> IfaceBooleanFormula
+ -> f (BooleanFormula (GhcPass p))
+traverseIfaceBooleanFormula f = go
+ where
+ go (IfVar nm ) = Var <$> f nm
+ go (IfAnd ibfs ) = And <$> traverse (fmap noLocA . go) ibfs
+ go (IfOr ibfs ) = Or <$> traverse (fmap noLocA . go) ibfs
+ go (IfParens ibf) = Parens <$> (fmap noLocA . go) ibf
\ No newline at end of file
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -35,7 +35,7 @@ import GHC.Core.Class ( className, classSCSelIds )
import GHC.Core.ConLike ( conLikeName )
import GHC.Core.FVs
import GHC.Core.DataCon ( dataConNonlinearType )
-import GHC.Types.FieldLabel
+import GHC.Types.FieldLabel ( FieldLabel(flSelector) )
import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Utils.Monad ( concatMapM, MonadIO(liftIO) )
@@ -2043,8 +2043,22 @@ 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 => ToHie (GenLocated SrcSpanAnnL (BooleanFormula (GhcPass p))) where
+ toHie (L span form) = case hiePass @p of
+ HieRn -> concatM $ makeNode form (locA span) : case form of
+ Var a ->
+ [ toHie $ C Use a
+ ]
+ And forms ->
+ [ toHie forms
+ ]
+ Or forms ->
+ [ toHie forms
+ ]
+ Parens f ->
+ [ toHie f
+ ]
+ HieTc -> concatM $ makeNode form (locA span) : case form of
Var a ->
[ toHie $ C Use a
]
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -35,7 +35,6 @@ module GHC.Iface.Syntax (
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
ifaceDeclFingerprints,
- fromIfaceBooleanFormula,
fromIfaceWarnings,
fromIfaceWarningTxt,
@@ -75,7 +74,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(..))
@@ -98,6 +96,7 @@ import Control.Monad
import System.IO.Unsafe
import Control.DeepSeq
import Data.Proxy
+import Data.List ( intersperse )
infixl 3 &&&
@@ -218,13 +217,7 @@ data IfaceBooleanFormula
| IfAnd [IfaceBooleanFormula]
| IfOr [IfaceBooleanFormula]
| IfParens IfaceBooleanFormula
-
-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)
+ deriving Eq
data IfaceTyConParent
= IfNoParent
@@ -1022,7 +1015,7 @@ pprIfaceDecl ss (IfaceClass { ifName = clas
, pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind)
, text "class" <+> pprIfaceDeclHead suppress_bndr_sig context ss clas binders <+> pprFundeps fds <+> pp_where
, nest 2 (vcat [ vcat asocs, vcat dsigs
- , ppShowAllSubs ss (pprMinDef $ fromIfaceBooleanFormula minDef)])]
+ , ppShowAllSubs ss (pprMinDef minDef)])]
where
pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where")
@@ -1039,13 +1032,30 @@ pprIfaceDecl ss (IfaceClass { ifName = clas
| showSub ss sg = Just $ pprIfaceClassOp ss sg
| otherwise = Nothing
- pprMinDef :: BooleanFormula IfLclName -> SDoc
- pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions
+ pprMinDef :: IfaceBooleanFormula -> SDoc
+ pprMinDef minDef = ppUnless (ifLclIsTrue minDef) $ -- hide empty definitions
text "{-# MINIMAL" <+>
- pprBooleanFormula
- (\_ def -> cparen (isLexSym def) (ppr def)) 0 (fmap ifLclNameFS minDef) <+>
+ pprifLclBooleanFormula
+ (\_ def -> let fs = ifLclNameFS def in cparen (isLexSym fs) (ppr fs)) 0 minDef <+>
text "#-}"
+ ifLclIsTrue :: IfaceBooleanFormula -> Bool
+ ifLclIsTrue (IfAnd []) = True
+ ifLclIsTrue _ = False
+
+ pprifLclBooleanFormula :: (Rational -> IfLclName -> SDoc)
+ -> Rational -> IfaceBooleanFormula -> SDoc
+ pprifLclBooleanFormula pprVar = go
+ where
+ go p (IfVar x) = pprVar p x
+ go p (IfAnd []) = cparen (p > 0) empty
+ go p (IfAnd xs) = pprAnd p (map (go 3) xs)
+ go _ (IfOr []) = keyword $ text "FALSE"
+ go p (IfOr xs) = pprOr p (map (go 2) xs)
+ go p (IfParens x) = go p x
+ pprAnd p = cparen (p > 3) . fsep . punctuate comma
+ pprOr p = cparen (p > 2) . fsep . intersperse vbar
+
-- See Note [Suppressing binder signatures] in GHC.Iface.Type
suppress_bndr_sig = SuppressBndrSig True
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -32,6 +32,7 @@ module GHC.IfaceToCore (
hydrateCgBreakInfo
) where
+
import GHC.Prelude
import GHC.ByteCode.Types
@@ -43,7 +44,7 @@ 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.Decl (traverseIfaceBooleanFormula)
import GHC.Iface.Syntax
import GHC.Iface.Load
import GHC.Iface.Env
@@ -124,7 +125,6 @@ import GHC.Types.TyThing
import GHC.Types.Error
import GHC.Fingerprint
-import qualified GHC.Data.BooleanFormula as BF
import Control.Monad
import GHC.Parser.Annotation
@@ -133,6 +133,7 @@ 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)
@@ -297,9 +298,21 @@ mergeIfaceDecl d1 d2
plusNameEnv_C mergeIfaceClassOp
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
+
+ -- specialized version of BooleanFormula's MkOr.
+ mkOr :: [IfaceBooleanFormula] -> IfaceBooleanFormula
+ mkOr = maybe (IfAnd []) (mkOr' . nub . concat) . mapM fromOr
+ where
+ fromOr bf = case bf of
+ (IfOr xs) -> Just xs
+ (IfAnd []) -> Nothing
+ _ -> Just [bf]
+ mkOr' [x] = x
+ mkOr' xs = IfOr xs
+
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
@@ -795,8 +808,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 <- traverseIfaceBooleanFormula (fmap noLocA . lookupIfaceTop . mkVarOccFS . ifLclNameFS) if_mindef
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_name)
=====================================
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
@@ -3700,27 +3700,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 :: { LBooleanFormula GhcPs }
: 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 }
: 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 (gl $2)
; return (h : $3) } }
-name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) }
+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) }
=====================================
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)
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -580,22 +580,20 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
tidy_errs = bagToList (mapBag (tidyDelayedError env) errs)
partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError], [(TcCoercion, CtLoc)])
- partition_errors = go [] [] [] []
- where
- go out_of_scope other_holes syn_eqs mult_co_errs []
- = (out_of_scope, other_holes, syn_eqs, mult_co_errs)
- go es1 es2 es3 es4 (err:errs)
- | (es1, es2, es3, es4) <- go es1 es2 es3 es4 errs
- = case err of
- DE_Hole hole
- | isOutOfScopeHole hole
- -> (hole : es1, es2, es3, es4)
- | otherwise
- -> (es1, hole : es2, es3, es4)
- DE_NotConcrete err
- -> (es1, es2, err : es3, es4)
- DE_Multiplicity mult_co loc
- -> (es1, es2, es3, (mult_co, loc):es4)
+ partition_errors []
+ = ([], [], [], [])
+ partition_errors (err:errs)
+ | (es1, es2, es3, es4) <- partition_errors errs
+ = case err of
+ DE_Hole hole
+ | isOutOfScopeHole hole
+ -> (hole : es1, es2, es3, es4)
+ | otherwise
+ -> (es1, hole : es2, es3, es4)
+ DE_NotConcrete err
+ -> (es1, es2, err : es3, es4)
+ DE_Multiplicity mult_co loc
+ -> (es1, es2, es3, (mult_co, loc):es4)
-- See Note [Suppressing confusing errors]
suppress :: ErrorItem -> Bool
=====================================
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]
=====================================
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)
=====================================
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)
-- | A "set cost centre" pragma for declarations
--
=====================================
compiler/Language/Haskell/Syntax/BooleanFormula.hs
=====================================
@@ -0,0 +1,87 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+
+module Language.Haskell.Syntax.BooleanFormula(
+ BooleanFormula(..), LBooleanFormula,
+ mkVar, mkFalse, mkTrue, mkBool, mkAnd, mkOr,
+ bfExplMap, bfExplTraverse) 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)
+
+-- jury rigged map and traverse functions.
+-- if we had Functor/Traversable (LbooleanFormula p) we could use as a constraint
+-- we wouldn't neeed the first higher order argument, but because LBooleanformula
+-- is a type synonym that's no can do.
+bfExplMap :: ((BooleanFormula p -> BooleanFormula p') -> LBooleanFormula p -> LBooleanFormula p')
+ -> (LIdP p -> LIdP p')
+ -> BooleanFormula p -> BooleanFormula p'
+bfExplMap lbfMap f = go
+ where
+ go (Var a ) = Var $ f a
+ go (And bfs) = And $ map (lbfMap go) bfs
+ go (Or bfs) = Or $ map (lbfMap go) bfs
+ go (Parens bf ) = Parens $ lbfMap go bf
+
+bfExplTraverse :: Applicative f
+ => ((BooleanFormula p -> f (BooleanFormula p')) -> LBooleanFormula p -> f (LBooleanFormula p'))
+ -> (LIdP p -> f (LIdP p'))
+ -> BooleanFormula p -> f (BooleanFormula p')
+bfExplTraverse lbfTraverse f = go
+ where
+ go (Var a ) = Var <$> f a
+ go (And bfs) = And <$> traverse @[] (lbfTraverse go) bfs
+ go (Or bfs) = Or <$> traverse @[] (lbfTraverse go) bfs
+ go (Parens bf ) = Parens <$> lbfTraverse go bf
+
+-- 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
=====================================
compiler/ghc.cabal.in
=====================================
@@ -989,6 +989,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
=====================================
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
=====================================
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
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2984,7 +2984,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
@@ -4695,7 +4695,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
=====================================
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
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -34,6 +34,7 @@ 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 (bfExplTraverse)
import Haddock.Backends.Hoogle (ppExportD)
import Haddock.GhcUtils
@@ -770,7 +771,7 @@ 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' <- bfExplTraverse traverse (traverse lookupRn) s
return $ MinimalSig noExtField (L l 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) = SrcSpanAnnL
type XRecCond a =
( XParTy a ~ AnnParen
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d8ae1043867e6a8148abbb815f80990e388ba09...bca81cf0145793749722524af7ac4f9984b0f1cc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d8ae1043867e6a8148abbb815f80990e388ba09...bca81cf0145793749722524af7ac4f9984b0f1cc
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/20241009/57c364ac/attachment-0001.html>
More information about the ghc-commits
mailing list