packages feed

th-reify-many (empty) → 0.1.1

raw patch · 5 files changed

+311/−0 lines, 5 filesdep +basedep +containersdep +mtlsetup-changed

Dependencies added: base, containers, mtl, safe, template-haskell, th-expand-syns

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Language/Haskell/TH/ReifyMany.hs view
@@ -0,0 +1,155 @@+-- | @th-transitive@ 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 transitively 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, TyConI dec) = recurse (name, dec)+    recurse' (_, PrimTyConI {}) = return (False, [])+    recurse' (_, info) = do+        report True $ "Unexpected info type in getTyConsTransitively: " ++ show info+        return (False, [])++-- | 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)+                minfo <- State.lift $ recover (return Nothing) (fmap Just (reify n))+                case minfo of+                    Just info -> do+                        (shouldEmit, ns) <- State.lift $ recurse (n, info)+                        (if shouldEmit+                             then fmap ((n, info):)+                             else id) $ fmap concat $ mapM go ns+                    _ -> return []++-- | 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 exsample, 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 <- getTyConsTransitively recurse initial+    return (map fst infos)+-}
+ src/Language/Haskell/TH/ReifyMany/Internal.hs view
@@ -0,0 +1,88 @@+module Language.Haskell.TH.ReifyMany.Internal where++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]]+decToFieldTypes (DataD _ _ _ cons _) = map conToFieldTypes cons+decToFieldTypes (NewtypeD _ _ _ con _) = [conToFieldTypes con]+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++-- | 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+    convertDec (InstanceD ctxt typ decs) = do+        typ' <- expandSyns typ+        return $ Just (TypeclassInstance ctxt typ' decs)+    convertDec _ = return Nothing++-- | 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.cabal view
@@ -0,0 +1,36 @@+name:              th-reify-many+version:           0.1.1+synopsis:          Recurseively reify template haskell datatype info++description:       @th-transitive@ 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 <mgsloan at gmail>+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.8+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