th-reify-many-0.1.6/src/0000755000000000000000000000000012423405071013162 5ustar0000000000000000th-reify-many-0.1.6/src/Language/0000755000000000000000000000000012423033762014711 5ustar0000000000000000th-reify-many-0.1.6/src/Language/Haskell/0000755000000000000000000000000012423033766016300 5ustar0000000000000000th-reify-many-0.1.6/src/Language/Haskell/TH/0000755000000000000000000000000012714273460016613 5ustar0000000000000000th-reify-many-0.1.6/src/Language/Haskell/TH/ReifyMany/0000755000000000000000000000000012714005614020510 5ustar0000000000000000th-reify-many-0.1.6/tests/0000755000000000000000000000000012473204525013543 5ustar0000000000000000th-reify-many-0.1.6/src/Language/Haskell/TH/ReifyMany.hs0000644000000000000000000001563112714273460021060 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | @th-reify-many@ provides functions for recursively reifying top -- level declarations. The main intended use case is for enumerating -- the names of datatypes reachable from an initial datatype, and -- passing these names to some function which generates instances. -- -- For example, in order to define 'Language.Haskell.TH.Syntax.Lift' -- instances for two mutually recursive datatypes, I could write -- something like: -- -- > {-# LANGUAGE TemplateHaskell #-} -- > import Language.Haskell.TH.ReifyMany (reifyManyWithoutInstances) -- > import Language.Haskell.TH.Lift (Lift(..), deriveLiftMany) -- > -- > data A = A B -- > -- > data B = B Int -- > -- > $(reifyManyWithoutInstances ''Lift [''A] (const True) >>= deriveLiftMany) -- -- One interesting feature of this is that it attempts to omit the -- types which already have an instance defined. For example, if -- @$(deriveLift ''B)@ is used before @deriveLiftMany@, it will omit -- the instance for B. -- -- Of course, the intended usecase for this involves many more -- datatypes - for example, syntax trees such as those found in TH. -- -- Note that 'reifyManyWithoutInstances' is rather imperfect in its -- testing of whether an instance exists, and whether an instance -- should exist. See this function's docs for details. module Language.Haskell.TH.ReifyMany where import qualified Control.Monad.State as State import Data.Maybe (isNothing) import qualified Data.Set as S import Language.Haskell.TH import Language.Haskell.TH.ReifyMany.Internal -- | Recursively enumerates type constructor declarations, halting -- when datatypes appear to already have an instance for the typeclass -- specified by the first 'Name' parameter. It guesses that an -- instance exists for a given datatype if it's used in the top -- constructor of any of its parameters (see 'instanceMatches'). -- -- This function is useful for bulk defining typeclass instances like -- @Binary@, @Lift@, @Data@, @Typeable@, etc. It isn't very clever, -- though - in particular it has the following limitations: -- -- * It only works well when type constructors mentioned in -- fields should all have instances defined for them. -- -- * It ignores data type / constructor constraints. -- -- * It ignores data / type families. -- -- It also takes a user-defined predicate, which is useful in -- situations where this attempts to descend into datatypes which do -- not need instances defined for them. -- -- Note that this will always initially yield the 'Name's of the -- initial types, regardless of whether they are instances or not. reifyManyWithoutInstances :: Name -> [Name] -> (Name -> Bool) -> Q [Name] reifyManyWithoutInstances clz initial recursePred = do insts <- getInstances clz let recurse (name, dec) | recursePred name && isNothing (lookupInstance insts name) = do return (isDataDec dec, decConcreteNames dec) recurse _ = return (False, []) infos <- reifyManyTyCons recurse initial return (map fst infos) -- | Like 'reifyMany', but specialized for recursively enumerating -- type constructor declarations, omitting 'PrimTyConI'. -- -- In order to have this behave like 'reifyManyWithoutInstances', but -- not do any instance filtering, use it with the 'isDataDec' and -- 'decConcreteNames' internal utilities. For example: -- -- > {-# LANGUAGE TemplateHaskell #-} -- > import Language.Haskell.TH -- > import Language.Haskell.TH.ReifyMany -- > import Language.Haskell.TH.ReifyMany.Internal -- > -- > $(do results <- reifyManyTyCons -- > (\(_, dec) -> return (isDataDec dec, decConcreteNames dec)) -- > [''Exp] -- > -- Display the results -- > reportError (show (map fst results)) -- > -- This TH splice doesn't generate any code. -- > return [] -- > ) reifyManyTyCons :: ((Name, Dec) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)] reifyManyTyCons recurse = reifyMany recurse' where recurse' (name, info) = do let skip thing = do report False $ "reifyManyTyCons skipping " ++ thing ++ " named " ++ pprint name return (False, []) unexpected thing = do fail $ "reifyManyTyCons encountered unexpected " ++ thing ++ " named " ++ pprint name case info of TyConI dec -> recurse (name, dec) PrimTyConI{} -> skip "prim type constructor" DataConI{} -> skip "data constructor" ClassI{} -> skip "class" ClassOpI{} -> unexpected "class method" VarI{} -> unexpected "value variable" TyVarI{} -> unexpected "type variable" #if MIN_VERSION_template_haskell(2,7,0) FamilyI{} -> skip "type or data family" #endif -- | Starting from a set of initial top level declarations, specified -- by @[Name]@, recursively enumerate other related declarations. The -- provided function determines whether the current info be included -- in the list of results, and which 'Name's to lookup next. This -- function handles keeping track of which 'Name's have already been -- visited. reifyMany :: ((Name, Info) -> Q (Bool, [Name])) -> [Name] -> Q [(Name, Info)] reifyMany recurse initial = State.evalStateT (fmap concat $ mapM go initial) S.empty where go :: Name -> State.StateT (S.Set Name) Q [(Name, Info)] go n = do seen <- State.get if S.member n seen then return [] else do State.put (S.insert n seen) info <- State.lift (reify n) (shouldEmit, ns) <- State.lift $ recurse (n, info) results <- fmap concat $ mapM go ns if shouldEmit then return ((n, info) : results) else return results -- | Like 'getDatatypesWithoutInstanceOf', but more precise as it uses -- the 'isInstance' function -- -- The typeclass is specified by a 'Name', and a function -- to take the concrete type to a list of the parameters for the -- typeclass. -- -- FIXME: this code is disabled because "isInstance" doesn't do any -- recursive instance resolution. For example, it yields 'True' when -- asked if the instance (Show [Int -> Int]) exists, since one exists -- for lists. {- getDataTypesWithoutInstancesOf' :: Name -> (Type -> [Type]) -> Name -> (Name -> Bool) -> Q [Name] getDataTypesWithoutInstancesOf' clz tysFunc initial recursePred = do let recurse (name, dec) | recursePred name && isNormalTyCon dec = do let tys = concat (decToFieldTypes dec) reportError ("before: " ++ show tys) filtered <- filterM (fmap not . recover (return True) . isInstance clz . tysFunc) tys State.when (not (null filtered)) $ reportError (show filtered) return (isDataDec dec, concatMap typeConcreteNames filtered) recurse _ = return (False, []) infos <- reifyManyTyCons recurse initial return (map fst infos) -} th-reify-many-0.1.6/src/Language/Haskell/TH/ReifyMany/Internal.hs0000644000000000000000000000774412714005614022634 0ustar0000000000000000{-# LANGUAGE CPP #-} module Language.Haskell.TH.ReifyMany.Internal where #if !(MIN_VERSION_template_haskell(2,7,0)) import Data.List (foldl') #endif import Data.Maybe (catMaybes) import Language.Haskell.TH import Language.Haskell.TH.ExpandSyns (expandSyns) import Safe (headMay, tailMay) -- | Returns 'True' if the 'Dec' is a 'DataD' or 'NewtypeD' isDataDec :: Dec -> Bool isDataDec DataD {} = True isDataDec NewtypeD {} = True isDataDec _ = False -- | Returns 'True' if the 'Dec' is a 'DataD', 'NewtypeD', or -- 'TySynD'. isNormalTyCon :: Dec -> Bool isNormalTyCon DataD {} = True isNormalTyCon NewtypeD {} = True isNormalTyCon TySynD {} = True isNormalTyCon _ = False -- | For data, newtype, and type declarations, yields a list of the -- types of the fields. In the case of a type synonyms, it just -- returns the body of the type synonym as a singleton list. decToFieldTypes :: Dec -> [[Type]] #if MIN_VERSION_template_haskell(2,11,0) decToFieldTypes (DataD _ _ _ _ cons _) = map conToFieldTypes cons decToFieldTypes (NewtypeD _ _ _ _ con _) = [conToFieldTypes con] #else decToFieldTypes (DataD _ _ _ cons _) = map conToFieldTypes cons decToFieldTypes (NewtypeD _ _ _ con _) = [conToFieldTypes con] #endif decToFieldTypes (TySynD _ _ ty) = [[ty]] decToFieldTypes _ = [] -- | Returns the types of the fields of the constructor. conToFieldTypes :: Con -> [Type] conToFieldTypes (NormalC _ xs) = map snd xs conToFieldTypes (RecC _ xs) = map (\(_, _, ty) -> ty) xs conToFieldTypes (InfixC (_, ty1) _ (_, ty2)) = [ty1, ty2] conToFieldTypes (ForallC _ _ con) = conToFieldTypes con #if MIN_VERSION_template_haskell(2,11,0) conToFieldTypes (GadtC _ xs _) = map snd xs conToFieldTypes (RecGadtC _ xs _) = map (\(_, _, ty) -> ty) xs #endif -- | Returns the names of all type constructors which aren't involved -- in constraints. typeConcreteNames :: Type -> [Name] typeConcreteNames (ForallT _ _ ty) = typeConcreteNames ty typeConcreteNames (AppT l r) = typeConcreteNames l ++ typeConcreteNames r typeConcreteNames (SigT ty _) = typeConcreteNames ty typeConcreteNames (ConT n) = [n] typeConcreteNames _ = [] -- | Returns the names of all type constructors used when defining -- type constructors. decConcreteNames :: Dec -> [Name] decConcreteNames = concatMap (concatMap typeConcreteNames) . decToFieldTypes -- | Datatype to capture the fields of 'InstanceD'. data TypeclassInstance = TypeclassInstance Cxt Type [Dec] deriving Show -- | Given the 'Name' of a class, yield all of the -- 'TypeclassInstance's, with synonyms expanded in the 'Type' field. getInstances :: Name -> Q [TypeclassInstance] getInstances clz = do res <- reify clz case res of ClassI _ xs -> fmap catMaybes $ mapM convertDec xs _ -> fail $ "Error in getInstances: " ++ show clz ++ " isn't a class" where #if MIN_VERSION_template_haskell(2,7,0) #if MIN_VERSION_template_haskell(2,11,0) convertDec (InstanceD _ ctxt typ decs) = do #else convertDec (InstanceD ctxt typ decs) = do #endif typ' <- expandSyns typ return $ Just (TypeclassInstance ctxt typ' decs) convertDec _ = return Nothing #else convertDec (ClassInstance _ _ ctxt _ typs) = do let typ = foldl' AppT (ConT clz) typs typ' <- expandSyns typ return $ Just (TypeclassInstance ctxt typ' []) #endif -- | Returns the first 'TypeclassInstance' where 'instanceMatches' -- returns true. lookupInstance :: [TypeclassInstance] -> Name -> Maybe TypeclassInstance lookupInstance xs n = headMay $ filter (`instanceMatches` n) xs -- | Checks if the given name is the head of one of the paramaters of -- the given 'TypeclassInstance'. instanceMatches :: TypeclassInstance -> Name -> Bool instanceMatches (TypeclassInstance _ typ _) n' = case tailMay $ map (headMay . unAppsT) $ unAppsT typ of Nothing -> False Just xs -> not $ null [() | Just (ConT n) <- xs, n == n'] -- | Breaks a type application like @A b c@ into [A, b, c]. unAppsT :: Type -> [Type] unAppsT = go [] where go xs (AppT l x) = go (x : xs) l go xs ty = ty : xs th-reify-many-0.1.6/tests/Main.hs0000644000000000000000000000112712473204525014764 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | The test works if it builds! module Main where import Control.Monad import Language.Haskell.TH.ReifyMany class C a b where method :: b -> a data A = A B (Maybe B) data B = B Int -- Tests support of type synonym instances. type B' = B instance C B' Int where method _ = B 0 $(do ns <- reifyManyWithoutInstances ''C [''A] (const True) when (ns /= [''A, ''Maybe]) $ fail "Didn't get expected list of datatypes." return [] ) main :: IO () main = putStrLn "worked!" th-reify-many-0.1.6/LICENSE0000644000000000000000000000275712423034641013414 0ustar0000000000000000Copyright Michael Sloan 2014 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Michael Sloan nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. th-reify-many-0.1.6/Setup.hs0000644000000000000000000000007412473204525014036 0ustar0000000000000000import Distribution.Simple main :: IO () main = defaultMain th-reify-many-0.1.6/th-reify-many.cabal0000644000000000000000000000333012714275001016050 0ustar0000000000000000name: th-reify-many version: 0.1.6 synopsis: Recurseively reify template haskell datatype info description: @th-reify-many@ provides functions for recursively reifying top level declarations. The main intended use case is for enumerating the names of datatypes reachable from an initial datatype, and passing these names to some function which generates instances. license: BSD3 license-file: LICENSE author: Michael Sloan maintainer: Michael Sloan homepage: http://github.com/mgsloan/th-reify-many bug-reports: http://github.com/mgsloan/th-reify-many/issues category: Template Haskell stability: Experimental cabal-version: >= 1.10 build-type: Simple source-repository head type: git location: git://github.com/mgsloan/th-reify-many library hs-source-dirs: src ghc-options: -Wall exposed-modules: Language.Haskell.TH.ReifyMany Language.Haskell.TH.ReifyMany.Internal -- Note: these lack version bounds because this library builds -- with the earliest and latest versions of all dependencies -- except for template-haskell. build-depends: base >= 4 && < 5 , containers , mtl , safe , template-haskell >= 2.5.0.0 , th-expand-syns default-language: Haskell2010 test-suite test type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Main.hs build-depends: base, th-reify-many, template-haskell default-language: Haskell2010