[Git][ghc/ghc][wip/ttg-booleanformula] review changes for BooleanFormula
Hassan Al-Awwadi (@hassan.awwadi)
gitlab at gitlab.haskell.org
Wed Oct 9 15:54:36 UTC 2024
Hassan Al-Awwadi pushed to branch wip/ttg-booleanformula at Glasgow Haskell Compiler / GHC
Commits:
9f34aa08 by Hassan Al-Awwadi at 2024-10-09T17:53:19+02:00
review changes for BooleanFormula
* Removed bfExprMap, instead bfMap is fully defined inside Ghc.Data.BooleanFormula
* Cleaned up some classes for BooleanFormula
* Simplified toIfaceBooleanFormula to no longer be a higher order function
* And removed fromIfaceBooleanFormula completely
- - - - -
6 changed files:
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/IfaceToCore.hs
- compiler/Language/Haskell/Syntax/BooleanFormula.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
Changes:
=====================================
compiler/GHC/Data/BooleanFormula.hs
=====================================
@@ -1,4 +1,5 @@
{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
--------------------------------------------------------------------------------
@@ -36,17 +37,35 @@ import Language.Haskell.Syntax.BooleanFormula
type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnL
--- the other part of jury rigging some fake instances for booleanformula
--- using the genlocated instances of Functor and Traversable.
+-- 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.
+
+-- 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 = bfExplMap fmap f
+bfMap f = go
+ where
+ 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 = bfExplTraverse traverse f
+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
+
+
{-
Note [Simplification of BooleanFormulas]
@@ -208,9 +227,7 @@ 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 Outputable (BooleanFormula GhcPs) where
- ppr = pprBooleanFormulaNormal
-instance Outputable (BooleanFormula GhcRn) where
+instance OutputableBndrId p => Outputable (BooleanFormula (GhcPass p)) where
ppr = pprBooleanFormulaNormal
pprBooleanFormulaNormal :: OutputableBndrId p => BooleanFormula (GhcPass p) -> SDoc
=====================================
compiler/GHC/Iface/Decl.hs
=====================================
@@ -16,7 +16,6 @@ module GHC.Iface.Decl
, toIfaceBooleanFormula
-- converting back
- , fromIfaceBooleanFormula
, traverseIfaceBooleanFormula
)
where
@@ -55,7 +54,7 @@ import GHC.Data.Maybe
import GHC.Data.BooleanFormula
import Data.List ( findIndex, mapAccumL )
-import Language.Haskell.Syntax.Extension (LIdP)
+import Language.Haskell.Syntax.Extension (IdP, LIdP)
{-
************************************************************************
@@ -294,7 +293,7 @@ classToIfaceDecl env clas
ifClassCtxt = tidyToIfaceContext env1 sc_theta,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
- ifMinDef = toIfaceBooleanFormula (mkIfLclName . getOccFS . unLoc) (classMinimalDef clas)
+ ifMinDef = toIfaceBooleanFormula (classMinimalDef clas)
}
(env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
@@ -343,21 +342,13 @@ tidyTyConBinders = mapAccumL tidyTyConBinder
tidyTyVar :: TidyEnv -> TyVar -> IfLclName
tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
-toIfaceBooleanFormula :: (LIdP (GhcPass p) -> IfLclName) -> BooleanFormula (GhcPass p) -> IfaceBooleanFormula
-toIfaceBooleanFormula f = go
+toIfaceBooleanFormula :: NamedThing (IdP (GhcPass p)) => BooleanFormula (GhcPass p) -> IfaceBooleanFormula
+toIfaceBooleanFormula = 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
+ go (Var nm ) = IfVar $ mkIfLclName . getOccFS . unLoc $ nm
+ go (And bfs ) = IfAnd $ map (go . unLoc) bfs
+ go (Or bfs ) = IfOr $ map (go . unLoc) bfs
+ go (Parens bf) = IfParens $ go . unLoc $ bf
traverseIfaceBooleanFormula :: Applicative f
=> (IfLclName -> f (LIdP (GhcPass p)))
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -2043,22 +2043,9 @@ instance ToHie PendingRnSplice where
instance ToHie PendingTcSplice where
toHie (PendingTcSplice _ e) = toHie e
-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
+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
]
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -299,20 +299,23 @@ mergeIfaceDecl d1 d2
(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
+ -- same as BooleanFormula's mkOr, but specialized to IfaceBooleanFormula,
+ -- which can be taught of as being (BooleanFormula IfacePass) morally.
+ -- In practice, however, its a seperate type so it needs its own function
+ -- It makes an Or and does some super basic simplification.
+ mkIfaceOr :: [IfaceBooleanFormula] -> IfaceBooleanFormula
+ mkIfaceOr = maybe (IfAnd []) (mkIfaceOr' . 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
+ mkIfaceOr' [x] = x
+ mkIfaceOr' xs = IfOr xs
in d1 { ifBody = (ifBody d1) {
ifSigs = ops,
- ifMinDef = mkOr [bf1, bf2]
+ ifMinDef = mkIfaceOr [bf1, bf2]
}
} `withRolesFrom` d2
-- It doesn't matter; we'll check for consistency later when
=====================================
compiler/Language/Haskell/Syntax/BooleanFormula.hs
=====================================
@@ -4,8 +4,8 @@
module Language.Haskell.Syntax.BooleanFormula(
BooleanFormula(..), LBooleanFormula,
- mkVar, mkFalse, mkTrue, mkBool, mkAnd, mkOr,
- bfExplMap, bfExplTraverse) where
+ mkVar, mkFalse, mkTrue, mkBool, mkAnd, mkOr
+ ) where
import Prelude hiding ( init, last )
import Data.List ( nub )
@@ -20,31 +20,6 @@ data BooleanFormula p = Var (LIdP p) | And [LBooleanFormula p] | Or [LBooleanFor
-- 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
=====================================
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,13 +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 (bfExplTraverse)
+import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..))
import Haddock.Backends.Hoogle (ppExportD)
import Haddock.GhcUtils
@@ -771,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' <- bfExplTraverse 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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9f34aa0884e755d4c6ebbb6f10e142bee245e78a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9f34aa0884e755d4c6ebbb6f10e142bee245e78a
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/2a8d76d4/attachment-0001.html>
More information about the ghc-commits
mailing list