Commit 01634277 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Fix Template Haskell's handling of infix GADT constructors

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
parent 6f2e7229
......@@ -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 -------------------
......
......@@ -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
......
......@@ -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])
......
......@@ -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.
......
......@@ -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,
......
......@@ -37,6 +37,12 @@
* 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
......
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)
{-# 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)
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
......@@ -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'])
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