Commit f16827f8 authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Ben Gamari

ApiAnnotations: BooleanFormula is not properly Located

At the moment BooleanFormula is defined as

  data BooleanFormula a = Var a | And [BooleanFormula a]
                        | Or [BooleanFormula a]
       deriving (Eq, Data, Typeable, Functor, Foldable, Traversable)

An API Annotation can only be attached to an item of the form Located a.

Replace this with a properly Located version, and attach the appropriate
API Annotations to it

Updates haddock submodule.

Test Plan: ./validate

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D1384

GHC Trac Issues: #11017
parent 84bf1eba
......@@ -37,7 +37,7 @@ import SrcLoc
import Var
import Bag
import FastString
import BooleanFormula (BooleanFormula)
import BooleanFormula (LBooleanFormula)
import Data.Data hiding ( Fixity )
import Data.List
......@@ -731,7 +731,7 @@ data Sig name
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
| MinimalSig SourceText (BooleanFormula (Located name))
| MinimalSig SourceText (LBooleanFormula (Located name))
-- Note [Pragma source text] in BasicTypes
deriving (Typeable)
......@@ -886,8 +886,8 @@ pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
instance Outputable TcSpecPrag where
ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
pprMinimalSig :: OutputableBndr name => BooleanFormula (Located name) -> SDoc
pprMinimalSig bf = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf)
pprMinimalSig :: OutputableBndr name => LBooleanFormula (Located name) -> SDoc
pprMinimalSig (L _ bf) = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf)
{-
************************************************************************
......
......@@ -43,7 +43,7 @@ import DynFlags
-- compiler/utils
import OrdList
import BooleanFormula ( BooleanFormula(..), mkTrue )
import BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue )
import FastString
import Maybes ( orElse )
import Outputable
......@@ -2080,11 +2080,10 @@ sigdecl :: { LHsDecl RdrName }
$ SigD (SpecInstSig (getSPEC_PRAGs $1) $3))
[mo $1,mj AnnInstance $2,mc $4] }
-- AZ TODO: Do we need locations in the name_formula_opt?
-- A minimal complete definition
| '{-# MINIMAL' name_boolformula_opt '#-}'
{% ams (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) (snd $2)))
(mo $1:mc $3:fst $2) }
{% ams (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) $2))
[mo $1,mc $3] }
activation :: { ([AddAnn],Maybe Activation) }
: {- empty -} { ([],Nothing) }
......@@ -2702,24 +2701,24 @@ ipvar :: { Located HsIPName }
-----------------------------------------------------------------------------
-- Warnings and deprecations
name_boolformula_opt :: { ([AddAnn],BooleanFormula (Located RdrName)) }
name_boolformula_opt :: { LBooleanFormula (Located RdrName) }
: name_boolformula { $1 }
| {- empty -} { ([],mkTrue) }
| {- empty -} { noLoc mkTrue }
name_boolformula :: { ([AddAnn],BooleanFormula (Located RdrName)) }
name_boolformula :: { LBooleanFormula (Located RdrName) }
: name_boolformula_and { $1 }
| name_boolformula_and '|' name_boolformula
{ ((mj AnnVbar $2:fst $1)++(fst $3)
,Or [snd $1,snd $3]) }
{% aa $1 (AnnVbar, $2)
>> return (sLL $1 $> (Or [$1,$3])) }
name_boolformula_and :: { ([AddAnn],BooleanFormula (Located RdrName)) }
name_boolformula_and :: { LBooleanFormula (Located RdrName) }
: name_boolformula_atom { $1 }
| name_boolformula_atom ',' name_boolformula_and
{ ((mj AnnComma $2:fst $1)++(fst $3), And [snd $1,snd $3]) }
{% aa $1 (AnnComma,$2) >> return (sLL $1 $> (And [$1,$3])) }
name_boolformula_atom :: { ([AddAnn],BooleanFormula (Located RdrName)) }
: '(' name_boolformula ')' { ((mop $1:mcp $3:(fst $2)),snd $2) }
| name_var { ([],Var $1) }
name_boolformula_atom :: { LBooleanFormula (Located RdrName) }
: '(' name_boolformula ')' {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] }
| name_var { sL1 $1 (Var $1) }
namelist :: { Located [Located RdrName] }
namelist : name_var { sL1 $1 [$1] }
......
......@@ -935,9 +935,9 @@ renameSig ctxt sig@(FixSig (FixitySig vs f))
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; return (FixSig (FixitySig new_vs f), emptyFVs) }
renameSig ctxt sig@(MinimalSig s bf)
renameSig ctxt sig@(MinimalSig s (L l bf))
= do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
return (MinimalSig s new_bf, emptyFVs)
return (MinimalSig s (L l new_bf), emptyFVs)
renameSig ctxt sig@(PatSynSig v (flag, qtvs) req prov ty)
= do { v' <- lookupSigOccRn ctxt sig v
......
......@@ -282,7 +282,7 @@ tcClassMinimalDef _clas sigs op_info
-- By default require all methods without a default
-- implementation whose names don't start with '_'
defMindef :: ClassMinimalDef
defMindef = mkAnd [ mkVar name
defMindef = mkAnd [ noLoc (mkVar name)
| (name, NoDM, _) <- op_info
, not (startsWithUnderscore (getOccName name)) ]
......@@ -342,8 +342,8 @@ findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
findMinimalDef = firstJusts . map toMinimalDef
where
toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
toMinimalDef (L _ (MinimalSig _ bf)) = Just (fmap unLoc bf)
toMinimalDef _ = Nothing
toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)
toMinimalDef _ = Nothing
{-
Note [Polymorphic methods]
......
......@@ -10,7 +10,7 @@
DeriveTraversable #-}
module BooleanFormula (
BooleanFormula(..),
BooleanFormula(..), LBooleanFormula,
mkFalse, mkTrue, mkAnd, mkOr, mkVar,
isFalse, isTrue,
eval, simplify, isUnsatisfied,
......@@ -28,12 +28,16 @@ import Data.Traversable ( Traversable )
import MonadUtils
import Outputable
import Binary
import SrcLoc
----------------------------------------------------------------------
-- Boolean formula type and smart constructors
----------------------------------------------------------------------
data BooleanFormula a = Var a | And [BooleanFormula a] | Or [BooleanFormula a]
type LBooleanFormula a = Located (BooleanFormula a)
data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a]
| Parens (LBooleanFormula a)
deriving (Eq, Data, Typeable, Functor, Foldable, Traversable)
mkVar :: a -> BooleanFormula a
......@@ -49,27 +53,28 @@ mkBool False = mkFalse
mkBool True = mkTrue
-- Make a conjunction, and try to simplify
mkAnd :: Eq a => [BooleanFormula a] -> BooleanFormula a
mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a
mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd
where
-- See Note [Simplification of BooleanFormulas]
fromAnd :: BooleanFormula a -> Maybe [BooleanFormula a]
fromAnd (And xs) = Just xs
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 (Or []) = Nothing -- in case of False we bail out, And [..,mkFalse,..] == mkFalse
fromAnd (L _ (Or [])) = Nothing
-- in case of False we bail out, And [..,mkFalse,..] == mkFalse
fromAnd x = Just [x]
mkAnd' [x] = x
mkAnd' [x] = unLoc x
mkAnd' xs = And xs
mkOr :: Eq a => [BooleanFormula a] -> BooleanFormula a
mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a
mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr
where
-- See Note [Simplification of BooleanFormulas]
fromOr (Or xs) = Just xs
fromOr (And []) = Nothing
fromOr (L _ (Or xs)) = Just xs
fromOr (L _ (And [])) = Nothing
fromOr x = Just [x]
mkOr' [x] = x
mkOr' [x] = unLoc x
mkOr' xs = Or xs
......@@ -121,8 +126,9 @@ isTrue _ = False
eval :: (a -> Bool) -> BooleanFormula a -> Bool
eval f (Var x) = f x
eval f (And xs) = all (eval f) xs
eval f (Or xs) = any (eval f) xs
eval f (And xs) = all (eval f . unLoc) xs
eval f (Or xs) = any (eval f . unLoc) xs
eval f (Parens x) = eval f (unLoc x)
-- Simplify a boolean formula.
-- The argument function should give the truth of the atoms, or Nothing if undecided.
......@@ -130,8 +136,9 @@ simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a
simplify f (Var a) = case f a of
Nothing -> Var a
Just b -> mkBool b
simplify f (And xs) = mkAnd (map (simplify f) xs)
simplify f (Or xs) = mkOr (map (simplify f) xs)
simplify f (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 (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
......@@ -151,13 +158,16 @@ isUnsatisfied f bf
-- 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 (`impliesAtom` y) xs -- we have all of xs, so one of them implying y is enough
Or xs `impliesAtom` y = all (`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
implies :: Eq a => BooleanFormula a -> BooleanFormula a -> Bool
x `implies` Var y = x `impliesAtom` y
x `implies` And ys = all (x `implies`) ys
x `implies` Or ys = any (x `implies`) ys
x `implies` And ys = all (implies x . unLoc) ys
x `implies` Or ys = any (implies x . unLoc) ys
x `implies` Parens y = x `implies` (unLoc y)
----------------------------------------------------------------------
-- Pretty printing
......@@ -173,9 +183,10 @@ pprBooleanFormula' pprVar pprAnd pprOr = go
where
go p (Var x) = pprVar p x
go p (And []) = cparen (p > 0) $ empty
go p (And xs) = pprAnd p (map (go 3) xs)
go p (And xs) = pprAnd p (map (go 3 . unLoc) xs)
go _ (Or []) = keyword $ text "FALSE"
go p (Or xs) = pprOr p (map (go 2) xs)
go p (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
......@@ -203,13 +214,15 @@ instance Outputable a => Outputable (BooleanFormula a) where
----------------------------------------------------------------------
instance Binary a => Binary (BooleanFormula a) where
put_ bh (Var x) = putByte bh 0 >> put_ bh x
put_ bh (And xs) = putByte bh 1 >> put_ bh xs
put_ bh (Or xs) = putByte bh 2 >> put_ bh xs
put_ bh (Var x) = putByte bh 0 >> put_ bh x
put_ bh (And xs) = putByte bh 1 >> put_ bh xs
put_ bh (Or xs) = putByte bh 2 >> put_ bh xs
put_ bh (Parens x) = putByte bh 3 >> put_ bh x
get bh = do
h <- getByte bh
case h of
0 -> Var <$> get bh
1 -> And <$> get bh
_ -> Or <$> get bh
0 -> Var <$> get bh
1 -> And <$> get bh
2 -> Or <$> get bh
_ -> Parens <$> get bh
......@@ -52,14 +52,20 @@
((TestBoolFormula.hs:15:5-19,AnnFunId), [TestBoolFormula.hs:15:5-7]),
((TestBoolFormula.hs:15:5-19,AnnSemi), [TestBoolFormula.hs:16:5]),
((TestBoolFormula.hs:(16,5)-(19,9),AnnClose), [TestBoolFormula.hs:19:7-9]),
((TestBoolFormula.hs:(16,5)-(19,9),AnnCloseP), [TestBoolFormula.hs:16:23, TestBoolFormula.hs:17:31,
TestBoolFormula.hs:18:38, TestBoolFormula.hs:18:31]),
((TestBoolFormula.hs:(16,5)-(19,9),AnnComma), [TestBoolFormula.hs:17:26, TestBoolFormula.hs:18:33]),
((TestBoolFormula.hs:(16,5)-(19,9),AnnOpen), [TestBoolFormula.hs:16:5-15]),
((TestBoolFormula.hs:(16,5)-(19,9),AnnOpenP), [TestBoolFormula.hs:16:18, TestBoolFormula.hs:17:18,
TestBoolFormula.hs:18:18, TestBoolFormula.hs:18:19]),
((TestBoolFormula.hs:(16,5)-(19,9),AnnVbar), [TestBoolFormula.hs:17:16, TestBoolFormula.hs:18:16,
TestBoolFormula.hs:18:25]),
((TestBoolFormula.hs:16:18-23,AnnCloseP), [TestBoolFormula.hs:16:23]),
((TestBoolFormula.hs:16:18-23,AnnOpenP), [TestBoolFormula.hs:16:18]),
((TestBoolFormula.hs:16:18-23,AnnVbar), [TestBoolFormula.hs:17:16]),
((TestBoolFormula.hs:17:18-31,AnnCloseP), [TestBoolFormula.hs:17:31]),
((TestBoolFormula.hs:17:18-31,AnnOpenP), [TestBoolFormula.hs:17:18]),
((TestBoolFormula.hs:17:18-31,AnnVbar), [TestBoolFormula.hs:18:16]),
((TestBoolFormula.hs:17:20-22,AnnComma), [TestBoolFormula.hs:17:26]),
((TestBoolFormula.hs:18:18-38,AnnCloseP), [TestBoolFormula.hs:18:38]),
((TestBoolFormula.hs:18:18-38,AnnOpenP), [TestBoolFormula.hs:18:18]),
((TestBoolFormula.hs:18:19-31,AnnCloseP), [TestBoolFormula.hs:18:31]),
((TestBoolFormula.hs:18:19-31,AnnComma), [TestBoolFormula.hs:18:33]),
((TestBoolFormula.hs:18:19-31,AnnOpenP), [TestBoolFormula.hs:18:19]),
((TestBoolFormula.hs:18:20-22,AnnVbar), [TestBoolFormula.hs:18:25]),
((TestBoolFormula.hs:(21,1)-(30,47),AnnClass), [TestBoolFormula.hs:21:1-5]),
((TestBoolFormula.hs:(21,1)-(30,47),AnnSemi), [TestBoolFormula.hs:32:1]),
((TestBoolFormula.hs:(21,1)-(30,47),AnnWhere), [TestBoolFormula.hs:21:13-17]),
......@@ -93,12 +99,13 @@
((TestBoolFormula.hs:29:5-20,AnnFunId), [TestBoolFormula.hs:29:5-8]),
((TestBoolFormula.hs:29:5-20,AnnSemi), [TestBoolFormula.hs:30:5]),
((TestBoolFormula.hs:30:5-47,AnnClose), [TestBoolFormula.hs:30:45-47]),
((TestBoolFormula.hs:30:5-47,AnnCloseP), [TestBoolFormula.hs:30:43]),
((TestBoolFormula.hs:30:5-47,AnnComma), [TestBoolFormula.hs:30:20, TestBoolFormula.hs:30:26,
TestBoolFormula.hs:30:37]),
((TestBoolFormula.hs:30:5-47,AnnOpen), [TestBoolFormula.hs:30:5-15]),
((TestBoolFormula.hs:30:5-47,AnnOpenP), [TestBoolFormula.hs:30:22]),
((TestBoolFormula.hs:30:5-47,AnnVbar), [TestBoolFormula.hs:30:32]),
((TestBoolFormula.hs:30:17-19,AnnComma), [TestBoolFormula.hs:30:20]),
((TestBoolFormula.hs:30:22-43,AnnCloseP), [TestBoolFormula.hs:30:43]),
((TestBoolFormula.hs:30:22-43,AnnOpenP), [TestBoolFormula.hs:30:22]),
((TestBoolFormula.hs:30:23-25,AnnComma), [TestBoolFormula.hs:30:26]),
((TestBoolFormula.hs:30:23-30,AnnVbar), [TestBoolFormula.hs:30:32]),
((TestBoolFormula.hs:30:34-36,AnnComma), [TestBoolFormula.hs:30:37]),
((TestBoolFormula.hs:(32,1)-(36,19),AnnInstance), [TestBoolFormula.hs:32:1-8]),
((TestBoolFormula.hs:(32,1)-(36,19),AnnSemi), [TestBoolFormula.hs:37:1]),
((TestBoolFormula.hs:(32,1)-(36,19),AnnWhere), [TestBoolFormula.hs:32:18-22]),
......
Subproject commit 987b5062482e20a032fb6358e655265b0b7a3cd2
Subproject commit 7f4519f0bb2a490fd9c1b42d37ae4f14390551b4
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment