Add Fixity info for infix types
authorRyanGlScott <ryan.gl.scott@gmail.com>
Wed, 5 Aug 2015 12:24:08 +0000 (14:24 +0200)
committerBen Gamari <ben@smart-cactus.org>
Wed, 5 Aug 2015 12:45:16 +0000 (14:45 +0200)
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

15 files changed:
compiler/typecheck/TcSplice.hs
docs/users_guide/7.12.1-notes.xml
libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
testsuite/tests/th/T10704.hs [new file with mode: 0644]
testsuite/tests/th/T10704.stdout [new file with mode: 0644]
testsuite/tests/th/T10704a.hs [new file with mode: 0644]
testsuite/tests/th/T1849.script
testsuite/tests/th/T2222.hs
testsuite/tests/th/T5358.hs
testsuite/tests/th/T5358.stderr
testsuite/tests/th/TH_reifyDecl1.hs
testsuite/tests/th/TH_reifyDecl1.stderr
testsuite/tests/th/all.T

index faebecd..e14796f 100644 (file)
@@ -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
index d8519d3..b026507 100644 (file)
                     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>
index 5d08227..6472104 100644 (file)
@@ -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,
index e792d1e..5fb7197 100644 (file)
@@ -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
index 04a15ac..9f7b510 100644 (file)
@@ -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.
diff --git a/testsuite/tests/th/T10704.hs b/testsuite/tests/th/T10704.hs
new file mode 100644 (file)
index 0000000..df52f7b
--- /dev/null
@@ -0,0 +1,24 @@
+{-# 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 ''(:@:))
diff --git a/testsuite/tests/th/T10704.stdout b/testsuite/tests/th/T10704.stdout
new file mode 100644 (file)
index 0000000..976c6a4
--- /dev/null
@@ -0,0 +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
diff --git a/testsuite/tests/th/T10704a.hs b/testsuite/tests/th/T10704a.hs
new file mode 100644 (file)
index 0000000..e332bba
--- /dev/null
@@ -0,0 +1,21 @@
+{-# 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
index 861b8d4..5ae77b9 100644 (file)
@@ -1,6 +1,6 @@
 :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)
index bba9231..7b5be78 100644 (file)
@@ -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 [] )
 
index 6a1d817..b70235f 100644 (file)
@@ -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)
             )
index f47a9fd..c899ed5 100644 (file)
@@ -1,9 +1,9 @@
 
-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) })
index 4c444f2..7e7c9f4 100644 (file)
@@ -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
+          ; [| () |] })
 
 
index bf5a819..503f533 100644 (file)
@@ -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
index 9e8f92d..a43cf57 100644 (file)
@@ -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'])