diff --git a/Language/Haskell/TH/ExpandSyns.hs b/Language/Haskell/TH/ExpandSyns.hs --- a/Language/Haskell/TH/ExpandSyns.hs +++ b/Language/Haskell/TH/ExpandSyns.hs @@ -98,71 +98,107 @@ noWarnTypeFamilies :: SynonymExpansionSettings noWarnTypeFamilies = mempty { sesWarnTypeFamilies = False } +warn :: String -> Q () +warn msg = +#if MIN_VERSION_template_haskell(2,8,0) + reportWarning +#else + report False +#endif + (packagename ++": "++"WARNING: "++msg) + + + type SynInfo = ([Name],Type) nameIsSyn :: SynonymExpansionSettings -> Name -> Q (Maybe SynInfo) nameIsSyn settings n = do i <- reify n case i of + ClassI {} -> no + ClassOpI {} -> no TyConI d -> decIsSyn settings d - ClassI {} -> return Nothing - PrimTyConI {} -> return Nothing -#if MIN_VERSION_template_haskell(2,11,0) - FamilyI (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) _ -> maybeWarnTypeFamily settings TypeFam name >> return Nothing - FamilyI (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) _ -> maybeWarnTypeFamily settings TypeFam name >> return Nothing - FamilyI (DataFamilyD _ _ _) _ -> return Nothing -#elif MIN_VERSION_template_haskell(2,7,0) - FamilyI (FamilyD flavour name _ _) _ -> maybeWarnTypeFamily settings flavour name >> return Nothing +#if MIN_VERSION_template_haskell(2,7,0) + FamilyI d _ -> decIsSyn settings d -- Called for warnings #endif - _ -> do - warn ("Don't know how to interpret the result of reify "++show n++" (= "++show i++").\n"++ - "I will assume that "++show n++" is not a type synonym.") - return Nothing + PrimTyConI {} -> no + DataConI {} -> no + VarI {} -> no + TyVarI {} -> no + where + no = return Nothing +decIsSyn :: SynonymExpansionSettings -> Dec -> Q (Maybe SynInfo) +decIsSyn settings = go + where + go (TySynD _ vars t) = return (Just (tyVarBndrGetName <$> vars,t)) -warn :: String -> Q () -warn msg = -#if MIN_VERSION_template_haskell(2,8,0) - reportWarning +#if MIN_VERSION_template_haskell(2,11,0) + go (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) = maybeWarnTypeFamily settings name >> no + go (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) = maybeWarnTypeFamily settings name >> no #else - report False + +#if MIN_VERSION_template_haskell(2,9,0) + go (ClosedTypeFamilyD name _ _ _) = maybeWarnTypeFamily settings name >> no #endif - (packagename ++": "++"WARNING: "++msg) + go (FamilyD TypeFam name _ _) = maybeWarnTypeFamily settings name >> no +#endif -#if MIN_VERSION_template_haskell(2,4,0) -maybeWarnTypeFamily :: SynonymExpansionSettings -> FamFlavour -> Name -> Q () -maybeWarnTypeFamily settings flavour name = - when (sesWarnTypeFamilies settings) $ + go (FunD {}) = no + go (ValD {}) = no + go (DataD {}) = no + go (NewtypeD {}) = no + go (ClassD {}) = no + go (InstanceD {}) = no + go (SigD {}) = no + go (ForeignD {}) = no - case flavour of - TypeFam -> - warn ("Type synonym families (and associated type synonyms) are currently not supported (they won't be expanded). Name of unsupported family: "++show name) +#if MIN_VERSION_template_haskell(2,8,0) + go (InfixD {}) = no +#endif - DataFam -> return () - -- Nothing to expand for data families, so no warning +#if MIN_VERSION_template_haskell(2,4,0) + go (PragmaD {}) = no #endif --- | Handles only declaration constructs that can be returned by 'reify'ing a type name. -decIsSyn :: SynonymExpansionSettings -> Dec -> Q (Maybe SynInfo) -decIsSyn settings = go - where - go (ClassD {}) = return Nothing - go (DataD {}) = return Nothing - go (NewtypeD {}) = return Nothing - go (TySynD _ vars t) = return (Just (tyVarBndrGetName <$> vars,t)) + -- Nothing to expand for data families, so no warning #if MIN_VERSION_template_haskell(2,11,0) - go (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) = maybeWarnTypeFamily settings TypeFam name >> return Nothing - go (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) = maybeWarnTypeFamily settings TypeFam name >> return Nothing - go (DataFamilyD _ _ _) = return Nothing + go (DataFamilyD {}) = no #elif MIN_VERSION_template_haskell(2,4,0) - go (FamilyD flavour name _ _) = maybeWarnTypeFamily settings flavour name >> return Nothing + go (FamilyD DataFam _ _ _) = no #endif - go x = do - warn ("Unrecognized declaration construct: "++ show x++". I will assume that it's not a type synonym declaration.") - return Nothing + +#if MIN_VERSION_template_haskell(2,4,0) + go (DataInstD {}) = no + go (NewtypeInstD {}) = no + go (TySynInstD {}) = no +#endif + +#if MIN_VERSION_template_haskell(2,9,0) + go (RoleAnnotD {}) = no +#endif + +#if MIN_VERSION_template_haskell(2,10,0) + go (StandaloneDerivD {}) = no + go (DefaultSigD {}) = no +#endif + + no = return Nothing + +#if MIN_VERSION_template_haskell(2,4,0) +maybeWarnTypeFamily :: SynonymExpansionSettings -> Name -> Q () +maybeWarnTypeFamily settings name = + when (sesWarnTypeFamilies settings) $ + warn ("Type synonym families (and associated type synonyms) are currently not supported (they won't be expanded). Name of unsupported family: "++show name) +#endif + + + + + -- | Calls 'expandSynsWith' with the default settings. diff --git a/changelog.markdown b/changelog.markdown --- a/changelog.markdown +++ b/changelog.markdown @@ -1,3 +1,7 @@ +## 0.4.2.0 + +* Eliminated warnings about unrecognized results of 'reify'. + ## 0.4.1.0 * Added a setting for suppressing warnings about type families. @@ -6,12 +10,12 @@ * Fixed build with GHC 8 / template-haskell-2.11 (Thanks to Christiaan Baaij) - Note: `substInCon` doesn't support GADT constructor with GHC 8 in this version + Note: `substInCon` doesn't support GADT constructors with GHC 8 in this version ## 0.3.0.6 -* Fixed build with current (commit 029a296a770addbd096bbfd6de0936327ee620d4) GHC 7.10 (Thanks to David Fox) +* Fixed build with current (commit 029a296a770addbd096bbfd6de0936327ee620d4) GHC 7.10 (Thanks to David Fox) ## 0.3.0.5 -* Fixed build with GHC 7.10.1-rc2 / template-haskell-2.10 (Thanks to Gabor Greif) +* Fixed build with GHC 7.10.1-rc2 / template-haskell-2.10 (Thanks to Gabor Greif) diff --git a/testing/Main.hs b/testing/Main.hs --- a/testing/Main.hs +++ b/testing/Main.hs @@ -9,22 +9,21 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax import Util -import Types - +import Types main = do putStrLn "Basic test..." - $(mkTest [t| forall a. Show a => a -> ForAll [] -> (Int,ApplyToInteger []) |] + $(mkTest [t| forall a. Show a => a -> ForAll [] -> (Int,ApplyToInteger []) |] --- GHC 7.8 always seems to consider the body of 'ForallT' to have a 'PlainTV', --- whereas it always has a 'KindedTV' with GHC 7.10 (in both cases, it doesn't appear +-- GHC 7.8 always seems to consider the body of 'ForallT' to have a 'PlainTV', +-- whereas it always has a 'KindedTV' with GHC 7.10 (in both cases, it doesn't appear -- to matter whether the definition of 'ForAll' is actually written with a kind signature). #if MIN_VERSION_template_haskell(2,10,0) [t| forall a. Show a => a -> (forall (x :: *). [] x) -> (Int,[] Integer) |] #else [t| forall a. Show a => a -> (forall x. [] x) -> (Int,[] Integer) |] #endif - + ) putStrLn "Variable capture avoidance test..." @@ -38,15 +37,15 @@ #endif expectedExpansion = - forallT - [y_0] + forallT + [y_0] (cxt []) (conT ''Either `appT` varT' "y" `appT` varT' "y_0" --> conT ''Int) -- the naive (and wrong) result would be: -- forall y. (forall y. Either y y -> Int) in - mkTest (forallT'' ["y"] (conT' "E" `appT` varT' "y")) + mkTest (forallT'' ["y"] (conT' "E" `appT` varT' "y")) (forallT'' ["y"] expectedExpansion)) putStrLn "Testing that it doesn't crash on type families (expanding them is not supported yet)" @@ -54,18 +53,18 @@ t = [t| (DF1 Int, TF1 Int, AT1 Int) |] in mkTest t t) - - putStrLn "Testing that the args of type family applications are handled" + + putStrLn "Testing that the args of type family applications are handled" $(mkTest [t| (DF1 Int', TF1 Int', AT1 Int') |] [t| (DF1 Int, TF1 Int, AT1 Int) |]) putStrLn "Higher-kinded synonym" - $(mkTest + $(mkTest [t| Either' (ListOf Int') (ListOf Char) |] [t| Either [Int] [Char] |]) putStrLn "Nested" - $(mkTest + $(mkTest [t| Int'' |] [t| Int |]) diff --git a/testing/Util.hs b/testing/Util.hs --- a/testing/Util.hs +++ b/testing/Util.hs @@ -1,24 +1,30 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Util where -import Language.Haskell.TH -import Language.Haskell.TH.ExpandSyns +import Language.Haskell.TH +import Language.Haskell.TH.ExpandSyns mkTest :: Q Type -> Q Type -> Q Exp mkTest input expected = do - input' <- input + input' <- input runIO . putStrLn $ ("info: input = "++show input') - expected' <- expected + expected' <- expected runIO . putStrLn $ ("info: expected = "++show expected') actual <- expandSyns input' runIO . putStrLn $ ("info: actual = "++show actual) - if (pprint expected'==pprint actual) then [| putStrLn "Ok" |] else [| error "expected /= actual" |] + if (pprint expected'==pprint actual) then [| putStrLn "Ok" |] else [| error "expected /= actual" |] -forallT' xs = forallT ((PlainTV . mkName) `fmap` xs) -forallT'' xs = forallT' xs (cxt []) +forallT' xs = forallT ((PlainTV . mkName) `fmap` xs) +forallT'' xs = forallT' xs (cxt []) varT' = varT . mkName conT' = conT . mkName x --> y = (arrowT `appT` x) `appT` y infixr 5 --> + +#if !MIN_VERSION_template_haskell(2,8,0) +reportWarning = report False +#endif + diff --git a/th-expand-syns.cabal b/th-expand-syns.cabal --- a/th-expand-syns.cabal +++ b/th-expand-syns.cabal @@ -1,5 +1,5 @@ name: th-expand-syns -version: 0.4.1.0 +version: 0.4.2.0 synopsis: Expands type synonyms in Template Haskell ASTs description: Expands type synonyms in Template Haskell ASTs category: Template Haskell @@ -10,6 +10,16 @@ cabal-version: >= 1.8 build-type: Simple extra-source-files: changelog.markdown +homepage: https://github.com/DanielSchuessler/th-expand-syns +tested-with: + GHC == 7.0.4 + GHC == 7.2.2 + GHC == 7.4.2 + GHC == 7.6.3 + GHC == 7.8.4 + GHC == 7.10.3 + GHC == 8.0.1 + GHC == 8.1 source-repository head type: git