Fix Template Haskell's handling of infix GADT constructors
authorRyanGlScott <ryan.gl.scott@gmail.com>
Fri, 8 Jan 2016 10:46:10 +0000 (11:46 +0100)
committerBen Gamari <ben@smart-cactus.org>
Fri, 8 Jan 2016 11:26:33 +0000 (12:26 +0100)
This is the second (and hopefully last) fix needed to make TH handle
GADTs properly (after D1465). This Diff addresses some issues with infix
GADT constructors, specifically:

* Before, you could not determine if a GADT constructor was declared
  infix because TH did not give you the ability to determine if there is
  a //user-specified// fixity declaration for that constructor. The
  return type of `reifyFixity` was changed to `Maybe Fixity` so that it
  yields `Just` the fixity is there is a fixity declaration, and
  `Nothing` otherwise (indicating it has `defaultFixity`).
* `DsMeta`/`Convert` were changed so that infix GADT constructors are
  turned into `GadtC`, not `InfixC` (which should be reserved for
  Haskell98 datatype declarations).
* Some minor fixes to the TH pretty-printer so that infix GADT
  constructors will be parenthesized in GADT signatures.

Fixes #11345.

Test Plan: ./validate

Reviewers: goldfire, austin, bgamari, jstolarek

Reviewed By: jstolarek

Subscribers: thomie

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

GHC Trac Issues: #11345

compiler/deSugar/DsMeta.hs
compiler/typecheck/TcSplice.hs
libraries/ghci/GHCi/Message.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
libraries/template-haskell/changelog.md
testsuite/tests/th/T10704.stdout
testsuite/tests/th/T11345.hs [new file with mode: 0644]
testsuite/tests/th/T11345.stdout [new file with mode: 0644]
testsuite/tests/th/all.T

index 0d8df6f..f0f5f1b 100644 (file)
@@ -1992,8 +1992,10 @@ repConstr (InfixCon st1 st2) Nothing [con]
          arg2 <- repBangTy st2
          rep2 infixCName [unC arg1, unC con, unC arg2]
 
-repConstr (InfixCon {}) (Just _) _ = panic "repConstr: infix GADT constructor?"
-repConstr _ _ _                    = panic "repConstr: invariant violated"
+repConstr (InfixCon {}) (Just _) _ =
+    panic "repConstr: infix GADT constructor should be in a PrefixCon"
+repConstr _ _ _ =
+    panic "repConstr: invariant violated"
 
 ------------ Types -------------------
 
index d24de8b..86bdbde 100644 (file)
@@ -1412,7 +1412,10 @@ reifyDataCon isGadtDataCon tys dc
                   ; return $ TH.RecGadtC [name]
                                      (zip3 (map (reifyName . flSelector) fields)
                                       dcdBangs r_arg_tys) res_ty }
-              | dataConIsInfix dc ->
+                -- We need to check not isGadtDataCon here because GADT
+                -- constructors can be declared infix.
+                -- See Note [Infix GADT constructors] in TcTyClsDecls.
+              | dataConIsInfix dc && not isGadtDataCon ->
                   ASSERT( length arg_tys == 2 )
                   return $ TH.InfixC (s1,r_a1) name (s2,r_a2)
               | isGadtDataCon -> do
@@ -1805,10 +1808,28 @@ reifySelector id tc
       Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
 
 ------------------------------
-reifyFixity :: Name -> TcM TH.Fixity
+reifyFixity :: Name -> TcM (Maybe TH.Fixity)
 reifyFixity name
-  = do  { fix <- lookupFixityRn name
-        ; return (conv_fix fix) }
+  = do { -- Repeat much of lookupFixityRn, because if we don't find a
+         -- user-supplied fixity declaration, we want to return Nothing
+         -- instead of defaultFixity
+       ; env <- getFixityEnv
+       ; case lookupNameEnv env name of
+              Just (FixItem _ fix) -> return (Just (conv_fix fix))
+              Nothing ->
+                do { this_mod <- getModule
+                   ; if nameIsLocalOrFrom this_mod name
+                        then return Nothing
+                        else
+                          -- Do NOT use mi_fix_fn to look up the fixity,
+                          -- because if there is a cache miss, it will return
+                          -- defaultFixity, which we want to avoid
+                          do { let doc = ptext (sLit "Checking fixity for")
+                                           <+> ppr name
+                             ; iface <- loadInterfaceForName doc name
+                             ; return . fmap conv_fix
+                                      . lookup (nameOccName name)
+                                      $ mi_fixities iface } } }
     where
       conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
       conv_dir BasicTypes.InfixR = TH.InfixR
index 4bc2d25..45b1951 100644 (file)
@@ -179,7 +179,7 @@ data Message a where
   Report :: Bool -> String -> Message (THResult ())
   LookupName :: Bool -> String -> Message (THResult (Maybe TH.Name))
   Reify :: TH.Name -> Message (THResult TH.Info)
-  ReifyFixity :: TH.Name -> Message (THResult TH.Fixity)
+  ReifyFixity :: TH.Name -> Message (THResult (Maybe TH.Fixity))
   ReifyInstances :: TH.Name -> [TH.Type] -> Message (THResult [TH.Dec])
   ReifyRoles :: TH.Name -> Message (THResult [TH.Role])
   ReifyAnnotations :: TH.AnnLookup -> TypeRep -> Message (THResult [ByteString])
index 899d27c..3f79920 100644 (file)
@@ -66,7 +66,7 @@ instance Ppr Info where
               case mb_d of { Nothing -> empty; Just d -> ppr d }]
 
 ppr_sig :: Name -> Type -> Doc
-ppr_sig v ty = ppr v <+> dcolon <+> ppr ty
+ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty
 
 pprFixity :: Name -> Fixity -> Doc
 pprFixity _ f | f == defaultFixity = empty
@@ -507,20 +507,24 @@ instance Ppr Con where
                          <+> pprBangType st2
 
     ppr (ForallC ns ctxt (GadtC c sts ty))
-        = commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty
+        = commaSepApplied c <+> dcolon <+> pprForall ns ctxt
+      <+> pprGadtRHS sts ty
 
     ppr (ForallC ns ctxt (RecGadtC c vsts ty))
-        = commaSep c <+> dcolon <+> pprForall ns ctxt
+        = commaSepApplied c <+> dcolon <+> pprForall ns ctxt
       <+> pprRecFields vsts ty
 
     ppr (ForallC ns ctxt con)
         = pprForall ns ctxt <+> ppr con
 
     ppr (GadtC c sts ty)
-        = commaSep c <+> dcolon <+> pprGadtRHS sts ty
+        = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty
 
     ppr (RecGadtC c vsts ty)
-        = commaSep c <+> dcolon <+> pprRecFields vsts ty
+        = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty
+
+commaSepApplied :: [Name] -> Doc
+commaSepApplied = commaSepWith (pprName' Applied)
 
 pprForall :: [TyVarBndr] -> Cxt -> Doc
 pprForall ns ctxt
@@ -731,7 +735,12 @@ instance Ppr Loc where
 -- Takes a list of printable things and prints them separated by commas followed
 -- by space.
 commaSep :: Ppr a => [a] -> Doc
-commaSep = sep . punctuate comma . map ppr
+commaSep = commaSepWith ppr
+
+-- Takes a list of things and prints them with the given pretty-printing
+-- function, separated by commas followed by space.
+commaSepWith :: (a -> Doc) -> [a] -> Doc
+commaSepWith pprFun = sep . punctuate comma . map pprFun
 
 -- Takes a list of printable things and prints them separated by semicolons
 -- followed by space.
index f571d6b..a3284c5 100644 (file)
@@ -67,7 +67,7 @@ class Monad m => Quasi m where
   qLookupName :: Bool -> String -> m (Maybe Name)
        -- True <=> type namespace, False <=> value namespace
   qReify          :: Name -> m Info
-  qReifyFixity    :: Name -> m Fixity
+  qReifyFixity    :: Name -> m (Maybe Fixity)
   qReifyInstances :: Name -> [Type] -> m [Dec]
        -- Is (n tys) an instance?
        -- Returns list of matching instance Decs
@@ -355,10 +355,13 @@ and to get information about @D@-the-type, use 'lookupTypeName'.
 reify :: Name -> Q Info
 reify v = Q (qReify v)
 
-{- | @reifyFixity nm@ returns the fixity of @nm@. If a fixity value cannot be
-found, 'defaultFixity' is returned.
+{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
+example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
+@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function
+@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns
+'Nothing', so you may assume @bar@ has 'defaultFixity'.
 -}
-reifyFixity :: Name -> Q Fixity
+reifyFixity :: Name -> Q (Maybe Fixity)
 reifyFixity nm = Q (qReifyFixity nm)
 
 {- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is,
index 9564e95..1c0919a 100644 (file)
   * Add `reifyConStrictness` to query a data constructor's `DecidedStrictness`
     values for its fields (#10697)
 
+  * The `ClassOpI`, `DataConI`, and `VarI` constructors no longer have a
+    `Fixity` field. Instead, all `Fixity` information for a given `Name` is
+    now determined through the `reifyFixity` function, which returns `Just` the
+    fixity if there is an explicit fixity declaration for that `Name`, and
+    `Nothing` otherwise (#10704 and #11345)
+
   * TODO: document API changes and important bugfixes
 
 
index 976c6a4..99b87e2 100644 (file)
@@ -1,16 +1,16 @@
-Fixity 0 InfixR
-Fixity 9 InfixL
-Fixity 9 InfixL
-Fixity 6 InfixL
-Fixity 9 InfixL
-Fixity 9 InfixL
-Fixity 9 InfixL
-Fixity 9 InfixL
-Fixity 0 InfixR
-Fixity 0 InfixR
-Fixity 1 InfixL
-Fixity 2 InfixL
-Fixity 3 InfixN
-Fixity 4 InfixN
-Fixity 5 InfixR
-Fixity 6 InfixR
+Just (Fixity 0 InfixR)
+Nothing
+Nothing
+Just (Fixity 6 InfixL)
+Nothing
+Nothing
+Nothing
+Nothing
+Just (Fixity 0 InfixR)
+Just (Fixity 0 InfixR)
+Just (Fixity 1 InfixL)
+Just (Fixity 2 InfixL)
+Just (Fixity 3 InfixN)
+Just (Fixity 4 InfixN)
+Just (Fixity 5 InfixR)
+Just (Fixity 6 InfixR)
diff --git a/testsuite/tests/th/T11345.hs b/testsuite/tests/th/T11345.hs
new file mode 100644 (file)
index 0000000..39dd8ad
--- /dev/null
@@ -0,0 +1,45 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Main (main) where
+
+import Language.Haskell.TH
+
+infixr 7 :***:
+data GADT a where
+  Prefix  :: Int -> Int -> GADT Int
+  (:***:) :: Int -> Int -> GADT Int
+
+$(do gadtName   <- newName "GADT2"
+     prefixName <- newName "Prefix2"
+     infixName  <- newName ":****:"
+     a          <- newName "a"
+     return [ DataD [] gadtName [KindedTV a StarT] Nothing
+              [ GadtC [prefixName]
+                [ (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
+                , (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
+                ] (AppT (ConT gadtName) (ConT ''Int))
+              , GadtC [infixName]
+                [ (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
+                , (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
+                ] (AppT (ConT gadtName) (ConT ''Int))
+              ] []
+            , InfixD (Fixity 7 InfixR) infixName
+            ])
+
+$(return [])
+
+deriving instance Show (GADT2 a)
+
+main :: IO ()
+main = do
+  -- Verify that infix GADT constructors reify correctly
+  putStrLn $(reify ''GADT   >>= stringE . pprint)
+  putStrLn $(reify '(:***:) >>= stringE . pprint)
+  -- Verify that reifyFixity returns something with (:***:)
+  -- (but not with Prefix, since it has no fixity declaration)
+  putStrLn $(reifyFixity 'Prefix  >>= stringE . show)
+  putStrLn $(reifyFixity '(:***:) >>= stringE . show)
+  -- Verify that spliced-in GADT infix constructors are actually infix
+  print (1 :****: 4)
diff --git a/testsuite/tests/th/T11345.stdout b/testsuite/tests/th/T11345.stdout
new file mode 100644 (file)
index 0000000..1230c63
--- /dev/null
@@ -0,0 +1,10 @@
+data Main.GADT (a_0 :: *) where
+    Main.Prefix :: GHC.Types.Int ->
+                   GHC.Types.Int -> Main.GADT GHC.Types.Int
+    (Main.:***:) :: GHC.Types.Int ->
+                    GHC.Types.Int -> Main.GADT GHC.Types.Int
+Constructor from Main.GADT: (Main.:***:) :: GHC.Types.Int ->
+                                            GHC.Types.Int -> Main.GADT GHC.Types.Int
+Nothing
+Just (Fixity 7 InfixR)
+1 :****: 4
index 55cbbee..b007bb3 100644 (file)
@@ -394,5 +394,6 @@ test('T10819',
      ['T10819.hs', '-v0 ' + config.ghc_th_way_flags])
 test('T10820', normal, compile_and_run, ['-v0'])
 test('T11341', normal, compile, ['-v0 -dsuppress-uniques'])
+test('T11345', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
 
 test('TH_finalizer', normal, compile, ['-v0'])