Commit 575abf42 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Add Fixity info for infix types

Template Haskell allows reification of fixity for infix functions and
data constructors, and not for infix types. This adds a `Fixity` field
to the relevant `Info` constructors that can have infix types (`ClassI`,
`TyConI`, and `FamilyI`).

I don't think that `VarI` or `PrimTyConI` can be infix, but I could be
wrong.

Test Plan: ./validate

Reviewers: austin, goldfire, bgamari

Reviewed By: goldfire, bgamari

Subscribers: thomie

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

GHC Trac Issues: #10704
parent fd6b24f1
......@@ -779,6 +779,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
qLookupName = lookupName
qReify = reify
qReifyFixity nm = lookupThName nm >>= reifyFixity
qReifyInstances = reifyInstances
qReifyRoles = reifyRoles
qReifyAnnotations = reifyAnnotations
......@@ -1037,20 +1038,18 @@ reifyThing :: TcTyThing -> TcM TH.Info
reifyThing (AGlobal (AnId id))
= do { ty <- reifyType (idType id)
; fix <- reifyFixity (idName id)
; let v = reifyName id
; case idDetails id of
ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
_ -> return (TH.VarI v ty Nothing fix)
ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))
_ -> return (TH.VarI v ty Nothing)
}
reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
reifyThing (AGlobal (AConLike (RealDataCon dc)))
= do { let name = dataConName dc
; ty <- reifyType (idType (dataConWrapId dc))
; fix <- reifyFixity name
; return (TH.DataConI (reifyName name) ty
(reifyName (dataConOrigTyCon dc)) fix)
(reifyName (dataConOrigTyCon dc)))
}
reifyThing (AGlobal (AConLike (PatSynCon ps)))
= noTH (sLit "pattern synonyms") (ppr $ patSynName ps)
......@@ -1059,8 +1058,7 @@ reifyThing (ATcId {tct_id = id})
= do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
-- though it may be incomplete
; ty2 <- reifyType ty1
; fix <- reifyFixity (idName id)
; return (TH.VarI (reifyName id) ty2 Nothing fix) }
; return (TH.VarI (reifyName id) ty2 Nothing) }
reifyThing (ATyVar tv tv1)
= do { ty1 <- zonkTcTyVar tv1
......@@ -1169,7 +1167,7 @@ reifyClass cls
; ops <- concatMapM reify_op op_stuff
; tvs' <- reifyTyVars tvs
; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops
; return (TH.ClassI dec insts ) }
; return (TH.ClassI dec insts) }
where
(tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
fds' = map reifyFunDep fds
......
......@@ -500,6 +500,17 @@
can use the <literal>liftData</literal> function which is
now exported from <literal>Language.Haskell.TH.Syntax</literal>.
</para>
</listitem>
<listitem>
<para>
<literal>Info</literal>'s constructors no longer have
<literal>Fixity</literal> fields. A <literal>qReifyFixity
</literal> function was added to the <literal>Quasi
</literal> type class (as well as the <literal>reifyFixity
</literal> function, specialized for <literal>Q</literal>)
to allow lookup of fixity information for any given
<literal>Name</literal>.
</para>
</listitem>
</itemizedlist>
</sect3>
......
......@@ -29,6 +29,8 @@ module Language.Haskell.TH(
-- *** Name lookup
lookupTypeName, -- :: String -> Q (Maybe Name)
lookupValueName, -- :: String -> Q (Maybe Name)
-- *** Fixity lookup
reifyFixity,
-- *** Instance lookup
reifyInstances,
isInstance,
......
......@@ -55,16 +55,14 @@ instance Ppr Info where
<+> (if is_unlifted then text "unlifted" else empty)
<+> text "type constructor" <+> quotes (ppr name)
<+> parens (text "arity" <+> int arity)
ppr (ClassOpI v ty cls fix)
= text "Class op from" <+> ppr cls <> colon <+>
vcat [ppr_sig v ty, pprFixity v fix]
ppr (DataConI v ty tc fix)
= text "Constructor from" <+> ppr tc <> colon <+>
vcat [ppr_sig v ty, pprFixity v fix]
ppr (ClassOpI v ty cls)
= text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty
ppr (DataConI v ty tc)
= text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty
ppr (TyVarI v ty)
= text "Type variable" <+> ppr v <+> equals <+> ppr ty
ppr (VarI v ty mb_d fix)
= vcat [ppr_sig v ty, pprFixity v fix,
ppr (VarI v ty mb_d)
= vcat [ppr_sig v ty,
case mb_d of { Nothing -> empty; Just d -> ppr d }]
ppr_sig :: Name -> Type -> Doc
......
......@@ -64,6 +64,7 @@ class (Applicative m, 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
qReifyInstances :: Name -> [Type] -> m [Dec]
-- Is (n tys) an instance?
-- Returns list of matching instance Decs
......@@ -109,6 +110,7 @@ instance Quasi IO where
qLookupName _ _ = badIO "lookupName"
qReify _ = badIO "reify"
qReifyFixity _ = badIO "reifyFixity"
qReifyInstances _ _ = badIO "reifyInstances"
qReifyRoles _ = badIO "reifyRoles"
qReifyAnnotations _ = badIO "reifyAnnotations"
......@@ -343,6 +345,12 @@ 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 :: Name -> Q Fixity
reifyFixity nm = Q (qReifyFixity nm)
{- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is,
if @nm@ is the name of a type class, then all instances of this class at the types @tys@
are returned. Alternatively, if @nm@ is the name of a data family or type family,
......@@ -427,6 +435,7 @@ instance Quasi Q where
qReport = report
qRecover = recover
qReify = reify
qReifyFixity = reifyFixity
qReifyInstances = reifyInstances
qReifyRoles = reifyRoles
qReifyAnnotations = reifyAnnotations
......@@ -1049,7 +1058,6 @@ data Info
Name
Type
ParentName
Fixity
-- | A \"plain\" type constructor. \"Fancier\" type constructors are returned using 'PrimTyConI' or 'FamilyI' as appropriate
| TyConI
......@@ -1072,7 +1080,6 @@ data Info
Name
Type
ParentName
Fixity
{- |
A \"value\" variable (as opposed to a type variable, see 'TyVarI').
......@@ -1088,7 +1095,6 @@ data Info
Name
Type
(Maybe Dec)
Fixity
{- |
A type variable.
......
{-# LANGUAGE MagicHash, TemplateHaskell #-}
module Main where
import GHC.Exts
import T10704a
main :: IO ()
main = do
putStrLn $(fixityExp ''(->))
putStrLn $(fixityExp ''Show)
putStrLn $(fixityExp 'show)
putStrLn $(fixityExp '(+))
putStrLn $(fixityExp ''Int)
putStrLn $(fixityExp ''Item)
putStrLn $(fixityExp ''Char#)
putStrLn $(fixityExp 'Just)
putStrLn $(fixityExp 'seq)
putStrLn $(fixityExp '($))
putStrLn $(fixityExp ''(:=>))
putStrLn $(fixityExp ''(:+:))
putStrLn $(fixityExp ''(:*:))
putStrLn $(fixityExp ''(:%:))
putStrLn $(fixityExp ''(:?:))
putStrLn $(fixityExp ''(:@:))
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
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, TypeOperators #-}
module T10704a where
import Language.Haskell.TH
infixl 1 :=>
infixl 2 :+:
infix 3 :*:
infix 4 :%:
infixr 5 :?:
infixr 6 :@:
class a :=> b
type a :+: b = Either a b
data a :*: b = a :*: b
newtype a :%: b = Percent (a, b)
data family a :?: b
type family a :@: b where a :@: b = Int
fixityExp :: Name -> Q Exp
fixityExp n = reifyFixity n >>= stringE . show
:set -XTemplateHaskell
import Language.Haskell.TH
let seeType n = do VarI _ t _ _ <- reify n; runIO $ putStrLn $ show t; [| return True |]
let seeType n = do VarI _ t _ <- reify n; runIO $ putStrLn $ show t; [| return True |]
let f = undefined :: Int -> Int
let g = undefined :: [Int]
let h = undefined :: (Int, Int)
......
......@@ -9,7 +9,7 @@ a = 1
$(return [])
b = $(do VarI _ t _ _ <- reify 'a
b = $(do VarI _ t _ <- reify 'a
runIO $ putStrLn ("inside b: " ++ pprint t)
[| undefined |])
......@@ -17,11 +17,11 @@ c = $([| True |])
$(return [])
d = $(do VarI _ t _ _ <- reify 'c
d = $(do VarI _ t _ <- reify 'c
runIO $ putStrLn ("inside d: " ++ pprint t)
[| undefined |] )
$(do VarI _ t _ _ <- reify 'c
$(do VarI _ t _ <- reify 'c
runIO $ putStrLn ("type of c: " ++ pprint t)
return [] )
......@@ -29,11 +29,11 @@ e = $([| True |])
$(return [])
f = $(do VarI _ t _ _ <- reify 'e
f = $(do VarI _ t _ <- reify 'e
runIO $ putStrLn ("inside f: " ++ pprint t)
[| undefined |] )
$(do VarI _ t _ _ <- reify 'e
$(do VarI _ t _ <- reify 'e
runIO $ putStrLn ("type of e: " ++ pprint t)
return [] )
......
......@@ -11,6 +11,6 @@ prop_x1 x = t1 x == t2 x
$(return [])
runTests = $( do VarI _ t _ _ <- reify (mkName "prop_x1")
runTests = $( do VarI _ t _ <- reify (mkName "prop_x1")
error $ ("runTest called error: " ++ pprint t)
)
T5358.hs:14:12:
T5358.hs:14:12: error:
Exception when trying to run compile-time code:
runTest called error: forall (t_0 :: *) . t_0 -> GHC.Types.Bool
Code: do { VarI _ t _ _ <- reify (mkName "prop_x1");
Code: do { VarI _ t _ <- reify (mkName "prop_x1");
($) error ((++) "runTest called error: " pprint t) }
In the untyped splice:
$(do { VarI _ t _ _ <- reify (mkName "prop_x1");
$(do { VarI _ t _ <- reify (mkName "prop_x1");
error $ ("runTest called error: " ++ pprint t) })
......@@ -63,26 +63,26 @@ data instance DF2 Bool = DBool
$(return [])
test :: ()
test = $(let
display :: Name -> Q ()
display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) }
in do { display ''T
; display ''R
; display ''List
; display ''Tree
; display ''IntList
; display ''Length
; display 'Leaf
; display 'm1
; display ''C1
; display ''C2
; display ''C3
; display ''AT1
; display ''AT2
; display ''TF1
; display ''TF2
; display ''DF1
; display ''DF2
; [| () |] })
test = $(let
display :: Name -> Q ()
display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) }
in do { display ''T
; display ''R
; display ''List
; display ''Tree
; display ''IntList
; display ''Length
; display 'Leaf
; display 'm1
; display ''C1
; display ''C2
; display ''C3
; display ''AT1
; display ''AT2
; display ''TF1
; display ''TF2
; display ''DF1
; display ''DF2
; [| () |] })
......@@ -12,7 +12,6 @@ newtype TH_reifyDecl1.Length = TH_reifyDecl1.Length GHC.Types.Int
Constructor from TH_reifyDecl1.Tree: TH_reifyDecl1.Leaf :: forall (a_0 :: *) . TH_reifyDecl1.Tree a_0
Class op from TH_reifyDecl1.C1: TH_reifyDecl1.m1 :: forall (a_0 :: *) . TH_reifyDecl1.C1 a_0 =>
a_0 -> GHC.Types.Int
infixl 3 TH_reifyDecl1.m1
class TH_reifyDecl1.C1 (a_0 :: *)
where TH_reifyDecl1.m1 :: forall (a_0 :: *) . TH_reifyDecl1.C1 a_0 =>
a_0 -> GHC.Types.Int
......
......@@ -347,3 +347,7 @@ test('T10306', normal, compile, ['-v0'])
test('T10596', normal, compile, ['-v0'])
test('T10620', normal, compile_and_run, ['-v0'])
test('T10638', normal, compile_fail, ['-v0'])
test('T10704',
extra_clean(['T10704a.o','T10704a.hi']),
multimod_compile_and_run,
['T10704', '-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