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

7 files changed, 81 insertions, 62 deletions

diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index b1b6e62f31..b1d13caf48 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -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)
 
 {-
 ************************************************************************
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 67d2adeb64..62d1114ae4 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -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] }
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 1a24c11893..159ed8bc1c 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -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
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index 2409b7b4e5..846a19b05f 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -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]
diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs
index 5925bdb758..41ac13963e 100644
--- a/compiler/utils/BooleanFormula.hs
+++ b/compiler/utils/BooleanFormula.hs
@@ -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
diff --git a/testsuite/tests/ghc-api/annotations/boolFormula.stdout b/testsuite/tests/ghc-api/annotations/boolFormula.stdout
index 62359ad1ad..c3caae10ea 100644
--- a/testsuite/tests/ghc-api/annotations/boolFormula.stdout
+++ b/testsuite/tests/ghc-api/annotations/boolFormula.stdout
@@ -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]),
diff --git a/utils/haddock b/utils/haddock
-Subproject 987b5062482e20a032fb6358e655265b0b7a3cd
+Subproject 7f4519f0bb2a490fd9c1b42d37ae4f14390551b