packages feed

th-context (empty) → 0.13

raw patch · 12 files changed

+1146/−0 lines, 12 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, containers, data-default, deepseq, ghc-prim, haskell-src-exts, hspec, hspec-core, mtl, syb, template-haskell, text, th-context, th-desugar, th-orphans, th-reify-many

Files

+ Language/Haskell/TH/Context.hs view
@@ -0,0 +1,230 @@+-- | Compute whether any existing instance satisfies some+-- context in a nearly correct fashion.+-- @+--    instance A m => B m where ...+-- @+-- I say "nearly correct" because there are cases which are+-- not handled exactly the way GHC behaves, which may lead to+-- false (positives?  negatives?)+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Language.Haskell.TH.Context+    ( InstMap+    , reifyInstancesWithContext+    , tellInstance+    -- * State/writer monad runners+    , evalContextState+    , execContextWriter+    , execContext+    , runContext+    ) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative ((<$>), (<*>))+import Data.Monoid (mempty)+#else+import Data.Maybe (isJust)+#endif+import Control.Monad (filterM)+import Control.Monad.State (MonadState, StateT, get, modify, evalStateT)+import Control.Monad.Writer (MonadWriter, tell, WriterT, execWriterT, runWriterT)+import Data.Generics (everywhere, mkT)+import Data.List ({-dropWhileEnd,-} intercalate)+import Data.Map as Map (Map, lookup, insert, singleton, elems)+import Language.Haskell.TH+import Language.Haskell.TH.Context.Expand (expandPred, expandClassP)+import Language.Haskell.TH.Context.Helpers (pprint')+import Language.Haskell.TH.Desugar as DS (DsMonad)+import Language.Haskell.TH.Syntax hiding (lift)+import Language.Haskell.TH.Instances ({- Ord instances from th-orphans -})++type InstMap pred = Map pred [InstanceDec]++-- | Like 'qReifyInstances', looks up all the instances that match the+-- given class name and argument types.  Unlike 'qReifyInstances',+-- only the ones that satisfy all the instance context predicates in+-- the environment are returned.  If there is already an instance that+-- satisfies the predicate built from the name and types it is+-- returned.  If not, this new predicate is inserted into the state+-- monad 'InstMap', associated with an empty list of predicates, and the+-- empty list is returned.  Later the caller can use 'tellInstance' to+-- associate instances with the predicate.+reifyInstancesWithContext :: (DsMonad m, MonadState (InstMap Pred) m) =>+                             Name -> [Type] -> m [InstanceDec]+reifyInstancesWithContext className typeParameters = do+       p <- expandClassP className typeParameters+       mp <- get+       case Map.lookup p mp of+         Just x -> return x+         Nothing -> do+           -- Add an entry with a bogus value to limit recursion on+           -- the predicate we are currently testing+           modify (Map.insert p [])+           -- Get all the instances of className that unify with the type parameters.+           insts <- qReifyInstances className typeParameters+           -- Filter out the ones that conflict with the instance context+           r <- filterM (testInstance className typeParameters) insts+           -- Now insert the correct value into the map and return it.+           modify (Map.insert p r)+           return r++-- | Test one of the instances returned by qReifyInstances against the+-- context we have computed so far.  We have already added a ClassP predicate+-- for the class and argument types, we now need to unify those with the+-- type returned by the instance and generate some EqualP predicates.+testInstance :: (DsMonad m, MonadState (InstMap Pred) m) => Name -> [Type] -> InstanceDec -> m Bool+testInstance className typeParameters (InstanceD instanceContext instanceType _) = do+  -- The new context consists of predicates derived by unifying the+  -- type parameters with the instance type, plus the prediates in the+  -- instance context field.+  mapM expandPred (instancePredicates (reverse typeParameters) instanceType ++ instanceContext) >>= testContext+    where+      instancePredicates :: [Type] -> Type -> [Pred]+#if MIN_VERSION_template_haskell(2,10,0)+      instancePredicates (x : xs) (AppT l r) = AppT (AppT EqualityT x) r : instancePredicates xs l+#else+      instancePredicates (x : xs) (AppT l r) = EqualP x r : instancePredicates xs l+#endif+      instancePredicates [] (ConT className') | className == className' = []+      instancePredicates _ _ =+          error $ (unlines ["testInstance: Failure unifying instance with arguments.  This should never",+                            "happen because qReifyInstance returned this instance for these exact arguments:",+                            " typeParameters=[" ++ intercalate ", " (map show typeParameters) ++ "]",+                            " instanceType=" ++ show instanceType])+testInstance _ _ x = error $ "qReifyInstances returned something that doesn't appear to be an instance declaration: " ++ show x++-- | Now we have predicates representing the unification of the type+-- parameters with the instance type.  Are they consistent?  Find out+-- using type synonym expansion, variable substitution, elimination of+-- vacuous predicates, and unification.+testContext :: (DsMonad m, MonadState (InstMap Pred) m) => [Pred] -> m Bool+testContext context =+    and <$> (mapM consistent =<< simplifyContext context)++-- | Perform type expansion on the predicates, then simplify using+-- variable substitution and eliminate vacuous equivalences.+simplifyContext :: (DsMonad m, MonadState (InstMap Pred) m) => [Pred] -> m [Pred]+simplifyContext context =+    do let context' = concat $ map unify context+       let context'' = foldl simplifyPredicate context' context'+       if (context'' == context) then return context'' else simplifyContext context''++-- | Try to simplify the context by eliminating of one of the predicates.+-- If we succeed start again with the new context.+simplifyPredicate :: [Pred] -> Pred -> [Pred]+#if MIN_VERSION_template_haskell(2,10,0)+simplifyPredicate context (AppT (AppT EqualityT v@(VarT _)) b) = everywhere (mkT (\ x -> if x == v then b else x)) context+simplifyPredicate context (AppT (AppT EqualityT a) v@(VarT _)) = everywhere (mkT (\ x -> if x == v then a else x)) context+simplifyPredicate context p@(AppT (AppT EqualityT a) b) | a == b = filter (/= p) context+#else+simplifyPredicate context (EqualP v@(VarT _) b) = everywhere (mkT (\ x -> if x == v then b else x)) context+simplifyPredicate context (EqualP a v@(VarT _)) = everywhere (mkT (\ x -> if x == v then a else x)) context+simplifyPredicate context p@(EqualP a b) | a == b = filter (/= p) context+#endif+simplifyPredicate context _ = context++-- | Test the context (predicates) against both the instances in the Q+-- monad and the additional instances that have accumulated in the+-- State monad.+#if 0+testContextWithState :: forall m pred. (DsMonad m, MonadState (InstMap Pred) m) => [Pred] -> m Bool+testContextWithState context = do+  -- Is the instance already in the Q monad?+  flag <- testContext context+  case flag of+    True -> return True+    -- Have we already generated and inserted the instance into the+    -- map in the state monad?  (Shouldn't we try this before calling+    -- testContext?)+    False -> and <$> mapM testPredicate context+    where+      testPredicate :: Pred -> m Bool+      testPredicate predicate = maybe False (not . null) <$> (Map.lookup predicate <$> get)+#endif++-- | Unify the two arguments of an EqualP predicate, return a list of+-- simpler predicates associating types with a variables.+unify :: Pred -> [Pred]+#if MIN_VERSION_template_haskell(2,10,0)+unify (AppT (AppT EqualityT (AppT a b)) (AppT c d)) = unify (AppT (AppT EqualityT a) c) ++ unify (AppT (AppT EqualityT b) d)+unify (AppT (AppT EqualityT (ConT a)) (ConT b)) | a == b = []+unify (AppT (AppT EqualityT a@(VarT _)) b) = [AppT (AppT EqualityT a) b]+unify (AppT (AppT EqualityT a) b@(VarT _)) = [AppT (AppT EqualityT a) b]+#else+unify (EqualP (AppT a b) (AppT c d)) = unify (EqualP a c) ++ unify (EqualP b d)+unify (EqualP (ConT a) (ConT b)) | a == b = []+unify (EqualP a@(VarT _) b) = [EqualP a b]+unify (EqualP a b@(VarT _)) = [EqualP a b]+#endif+unify x = [x]++-- | Decide whether a predicate is consistent with the accumulated+-- context.  Use recursive calls to qReifyInstancesWithContext when+-- we encounter a class name applied to a list of type parameters.+consistent :: (DsMonad m, MonadState (InstMap Pred) m) => Pred -> m Bool+#if MIN_VERSION_template_haskell(2,10,0)+consistent typ+    | isJust (unfoldInstance typ) =+        let Just (className, typeParameters) = unfoldInstance typ in+        (not . null) <$> reifyInstancesWithContext className typeParameters+consistent (AppT (AppT EqualityT (AppT a b)) (AppT c d)) =+    -- I'm told this is incorrect in the presence of type functions+    (&&) <$> consistent (AppT (AppT EqualityT a) c) <*> consistent (AppT (AppT EqualityT b) d)+consistent (AppT (AppT EqualityT (VarT _)) _) = return True+consistent (AppT (AppT EqualityT _) (VarT _)) = return True+consistent (AppT (AppT EqualityT a) b) | a == b = return True+consistent (AppT (AppT EqualityT _) _) = return False+consistent typ = error $ "Unexpected Pred: " ++ pprint typ+#else+consistent (EqualP (AppT a b) (AppT c d)) =+    -- I'm told this is incorrect in the presence of type functions+    (&&) <$> consistent (EqualP a c) <*> consistent (EqualP b d)+consistent (EqualP (VarT _) _) = return True+consistent (EqualP _ (VarT _)) = return True+consistent (EqualP a b) | a == b = return True+consistent (EqualP _ _) = return False+consistent (ClassP className typeParameters) =+    (not . null) <$> reifyInstancesWithContext className typeParameters -- Do we need additional context here?+#endif++-- | Declare an instance to the state and writer monads.  After this,+-- the instance predicate (constructed from class namd and type+-- parameters) will be considered part of the context for subsequent+-- calls to qReifyInstancesWithContext.  The instance will be returned+-- when the writer monad exists so it can be spliced into to program.+tellInstance :: (DsMonad m, MonadWriter (InstMap Pred) m, MonadState (InstMap Pred) m, Quasi m) =>+                Dec -> m ()+tellInstance inst@(InstanceD _ instanceType _) =+    do let Just (className, typeParameters) = unfoldInstance instanceType+#if MIN_VERSION_template_haskell(2,10,0)+       p <- expandPred $ foldl AppT (ConT className) typeParameters+#else+       p <- expandPred $ ClassP className typeParameters+#endif+       st <- get+       case Map.lookup p st of+         Just (_ : _) -> return ()+         _ -> do -- trace ("  " ++ pprint' instanceType) (return ())+                 tell $ Map.singleton p [inst]+                 modify $ Map.insert p [inst]+tellInstance inst = error $ "tellInstance - Not an instance: " ++ pprint' inst++unfoldInstance :: Type -> Maybe (Name, [Type])+unfoldInstance (ConT name) = Just (name, [])+unfoldInstance (AppT t1 t2) = maybe Nothing (\ (name, types) -> Just (name, types ++ [t2])) (unfoldInstance t1)+unfoldInstance _ = Nothing++evalContextState :: Monad m => StateT (InstMap Pred) m r -> m r+evalContextState action = evalStateT action (mempty :: (InstMap Pred))++execContextWriter :: Monad m => WriterT (InstMap Pred) m () -> m (InstMap Pred)+execContextWriter = execWriterT++-- | Typical use: run both state and writer monads to generate a list of+-- instance declarations.+execContext :: (Monad m, Functor m) => StateT (InstMap Pred) (WriterT (InstMap Pred) m) () -> m [Dec]+execContext action = (concat . Map.elems) <$> (execWriterT $ evalContextState action)++runContext :: (Monad m, Functor m) => StateT (InstMap Pred) (WriterT (InstMap Pred) m) r -> m (r, (InstMap Pred))+runContext action = runWriterT $ evalContextState action
+ Language/Haskell/TH/Context/Expand.hs view
@@ -0,0 +1,80 @@+-- | The 'Expanded' class helps keep track of which 'Type' values have+-- been fully expanded to a canonical form.  This lets us use the 'Eq'+-- and 'Ord' relationships on 'Type' and 'Pred' values when reasoning+-- about instance context.+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Language.Haskell.TH.Context.Expand+    ( Expanded(markExpanded, runExpanded)+    , expandType+    , expandPred+    , expandClassP+    , E+    ) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif+import Language.Haskell.Exts.Syntax ()+import Language.Haskell.TH+import Language.Haskell.TH.Desugar as DS (DsMonad, dsType, expand, typeToTH)+import Language.Haskell.TH.Instances ()+import Prelude hiding (pred)++-- | This class lets us use the same expand* functions to work with+-- specially marked expanded types or with the original types.+class Expanded un ex | ex -> un where+    markExpanded :: un -> ex -- | Unsafely mark a value as expanded+    runExpanded :: ex -> un -- | Strip mark off an expanded value++-- | Apply the th-desugar expand function to a 'Type' and mark it as expanded.+expandType :: (DsMonad m, Expanded Type e)  => Type -> m e+expandType typ = markExpanded <$> DS.typeToTH <$> (DS.dsType typ >>= DS.expand)++-- | Apply the th-desugar expand function to a 'Pred' and mark it as expanded.+-- Note that the definition of 'Pred' changed in template-haskell-2.10.0.0.+expandPred :: (DsMonad m, Expanded Pred e)  => Pred -> m e+#if MIN_VERSION_template_haskell(2,10,0)+expandPred pred = markExpanded <$> expandType pred+#else+expandPred (ClassP className typeParameters) = markExpanded <$> ClassP className <$> mapM expandType typeParameters+expandPred (EqualP type1 type2) = markExpanded <$> (EqualP <$> expandType type1 <*> expandType type2)+#endif++-- | Expand a list of 'Type' and build an expanded 'ClassP' 'Pred'.+expandClassP :: forall m e. (DsMonad m, Expanded Pred e)  => Name -> [Type] -> m e+expandClassP className typeParameters =+    markExpanded <$>+#if MIN_VERSION_template_haskell(2,10,0)+      (expandType $ foldl AppT (ConT className) typeParameters) :: m e+#else+      ClassP className <$> mapM expandType typeParameters+#endif++-- | A concrete type for which Expanded instances are declared below.+newtype E a = E a deriving (Eq, Ord, Show)++instance Expanded Type Type where+    markExpanded = id+    runExpanded = id++instance Expanded Type (E Type) where+    markExpanded = E+    runExpanded (E x) = x++#if !MIN_VERSION_template_haskell(2,10,0)+instance Expanded Pred Pred where+    markExpanded = id+    runExpanded = id++instance Expanded Pred (E Pred) where+    markExpanded = E+    runExpanded (E x) = x+#endif++instance Ppr a => Ppr (E a) where+    ppr (E x) = ppr x
+ Language/Haskell/TH/Context/Helpers.hs view
@@ -0,0 +1,134 @@+-- | Helper functions for dealing with record fields, type shape, type+-- arity, primitive types, and pretty printing.+{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.Haskell.TH.Context.Helpers+    ( -- * Declaration shape+      FieldType(FieldType, fPos, fNameAndType)+    , fName+    , fType+    , prettyField+    , constructorFields+    , foldShape+    -- * Constructor deconstructors+    , constructorName+    -- * Queries+    , typeArity+    , unlifted+    -- * Pretty print without extra whitespace+    , pprint'+    ) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative ((<$>), (<*>))+#endif+import Data.Data (Data)+import Data.Typeable (Typeable)+import Language.Haskell.Exts.Syntax ()+import Language.Haskell.TH+import Language.Haskell.TH.Desugar ({- instances -})+import Language.Haskell.TH.Syntax hiding (lift)++data FieldType+    = FieldType+      { fPos :: Int+      , fNameAndType :: Either StrictType VarStrictType }+    deriving (Eq, Ord, Show, Data, Typeable)++fName :: FieldType -> Maybe Name+fName = either (\ (_, _) -> Nothing) (\ (x, _, _) -> Just x) . fNameAndType++prettyField :: FieldType -> String+prettyField fld = maybe (show (fPos fld)) nameBase (fName fld)++-- | fType' with leading foralls stripped+fType :: FieldType -> Type+fType = either (\ (_, x) -> x) (\ (_, _, x) -> x) . fNameAndType++-- | Given the list of constructors from a Dec, dispatch on the+-- different levels of complexity of the type they represent - a+-- wrapper is a single arity one constructor, an enum is+-- several arity zero constructors, and so on.+foldShape :: Monad m =>+             ([(Con, [FieldType])] -> m r) -- dataFn - several constructors not all of which are arity zero+          -> (Con -> [FieldType] -> m r)   -- recordFn - one constructor which has arity greater than one+          -> ([Con] -> m r)                -- enumFn - all constructors are of arity zero+          -> (Con -> FieldType -> m r)     -- wrapperFn - one constructor of arity one+          -> [Con] -> m r+foldShape dataFn recordFn enumFn wrapperFn cons =+    case zip cons (map constructorFields cons) :: [(Con, [FieldType])] of+      [(con, [fld])] ->+          wrapperFn con fld+      [(con, flds)] ->+          recordFn con flds+      pairs | all (== 0) (map (length . snd) pairs) ->+          enumFn (map fst pairs)+      pairs ->+          dataFn pairs++constructorName :: Con -> Name+constructorName (ForallC _ _ con) = constructorName con+constructorName (NormalC name _) = name+constructorName (RecC name _) = name+constructorName (InfixC _ name _) = name++constructorFields :: Con -> [FieldType]+constructorFields (ForallC _ _ con) = constructorFields con+constructorFields (NormalC _ ts) = map (uncurry FieldType) (zip [1..] (map Left ts))+constructorFields (RecC _ ts) = map (uncurry FieldType) (zip [1..] (map Right ts))+constructorFields (InfixC t1 _ t2) = map (uncurry FieldType) [(1, Left t1), (2, Left t2)]++-- | Compute the arity of a type - the number of type parameters that+-- must be applied to it in order to obtain a concrete type.+typeArity :: Quasi m => Type -> m Int+typeArity (ForallT _ _ typ) = typeArity typ+typeArity ListT = return 1+typeArity (VarT _) = return 1+typeArity (TupleT n) = return n+typeArity (AppT t _) = typeArity t >>= \ n -> return $ n - 1+typeArity (ConT name) = qReify name >>= infoArity+    where+      infoArity (TyConI dec) = decArity dec+      infoArity (PrimTyConI _ _ _) = return 0+      infoArity (FamilyI dec _) = decArity dec+      infoArity info = error $ "typeArity - unexpected: " ++ pprint' info+      decArity (DataD _ _ vs _ _) = return $ length vs+      decArity (NewtypeD _ _ vs _ _) = return $ length vs+      decArity (TySynD _ vs t) = typeArity t >>= \ n -> return $ n + length vs+      decArity (FamilyD _ _ vs _mk) = return $ {- not sure what to do with the kind mk here -} length vs+      decArity dec = error $ "decArity - unexpected: " ++ show dec+typeArity typ = error $ "typeArity - unexpected type: " ++ show typ++-- | Pretty print a 'Ppr' value on a single line with each block of+-- white space (newlines, tabs, etc.) converted to a single space.+pprint' :: Ppr a => a -> [Char]+pprint' typ = unwords $ words $ pprint typ++-- | Does the type or the declaration to which it refers contain a+-- primitive (aka unlifted) type?  This will traverse down any 'Dec'+-- to the named types, and then check whether any of their 'Info'+-- records are 'PrimTyConI' values.+class IsUnlifted t where+    unlifted :: Quasi m => t -> m Bool++instance IsUnlifted Dec where+    unlifted (DataD _ _ _ cons _) = or <$> mapM unlifted cons+    unlifted (NewtypeD _ _ _ con _) = unlifted con+    unlifted (TySynD _ _ typ) = unlifted typ+    unlifted _ = return False++instance IsUnlifted Con where+    unlifted (ForallC _ _ con) = unlifted con+    unlifted (NormalC _ ts) = or <$> mapM (unlifted . snd) ts+    unlifted (RecC _ ts) = or <$> mapM (\ (_, _, t) -> unlifted t) ts+    unlifted (InfixC t1 _ t2) = or <$> mapM (unlifted . snd) [t1, t2]++instance IsUnlifted Type where+    unlifted (ForallT _ _ typ) = unlifted typ+    unlifted (ConT name) = qReify name >>= unlifted+    unlifted (AppT t1 t2) = (||) <$> unlifted t1 <*> unlifted t2+    unlifted _ = return False++instance IsUnlifted Info where+    unlifted (PrimTyConI _ _ _) = return True+    unlifted _ = return False -- traversal stops here
+ Language/Haskell/TH/Context/Simple.hs view
@@ -0,0 +1,36 @@+-- | Naive instance filtering (as in @th-reify-many@.)  Mostly for comparison+-- to @qReifyInstancesWithContext@.+module Language.Haskell.TH.Context.Simple+    ( missingInstances+    , simpleMissingInstanceTest+    ) where++import Data.Maybe (catMaybes)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Instances ({- Ord instances from th-orphans -})++-- | Apply a filter such as 'simpleMissingInstanceTest' to a list of+-- instances, resulting in a non-overlapping list of instances.+missingInstances :: Quasi m => (Dec -> m Bool) -> m [Dec] -> m [Dec]+missingInstances test decs = decs >>= mapM (\ dec -> test dec >>= \ flag -> return $ if flag then Just dec else Nothing) >>= return . catMaybes++-- | Return True if no instance matches the types (ignoring the instance context.)+-- Passing qReifyInstance as the reifyInstanceFunction argument gives a naive test,+-- passing qReifyInstanceWithContext will also accept (return True for) instances+-- which...+simpleMissingInstanceTest :: Quasi m => Dec -> m Bool+simpleMissingInstanceTest dec@(InstanceD _ typ _) =+    case unfoldInstance typ of+      Just (name, types) -> do+        -- trace ("name: " ++ show name ++ ", types=" ++ show types) (return ())+        insts <- qReifyInstances name types+        -- trace ("insts: " ++ show (map pprint insts)) (return ())+        return $ null insts+      Nothing -> error $ "simpleMissingInstanceTest - invalid instance: " ++ pprint dec+simpleMissingInstanceTest dec = error $ "simpleMissingInstanceTest - invalid instance: " ++ pprint dec++unfoldInstance :: Type -> Maybe (Name, [Type])+unfoldInstance (ConT name) = Just (name, [])+unfoldInstance (AppT t1 t2) = maybe Nothing (\ (name, types) -> Just (name, types ++ [t2])) (unfoldInstance t1)+unfoldInstance _ = Nothing
+ Language/Haskell/TH/TypeGraph.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall #-}+module Language.Haskell.TH.TypeGraph+    ( VertexStatus(..)+    , TypeGraphEdges+    , typeGraphEdges+    , typeGraphVertices+    , typeGraph+    ) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+import Data.Monoid (mempty)+#endif+import Control.Monad.State (execStateT, modify, MonadState(get), StateT)+import Control.Monad.Trans (lift)+import Data.Default (Default(def))+import Data.Graph (Graph, Vertex, graphFromEdges)+import Data.Map as Map (Map, keys, lookup, toList, update, alter)+import Data.Set as Set (insert, Set, empty, fromList, toList)+import Language.Haskell.Exts.Syntax ()+import Language.Haskell.TH -- (Con, Dec, nameBase, Type)+import Language.Haskell.TH.Desugar as DS (DsMonad)+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.Syntax (Quasi(..))++type TypeGraphEdges typ = Map typ (Set typ)++-- | When a VertexStatus value is associated with a Type it describes+-- alterations in the type graph from the usual default.+data VertexStatus typ+    = Vertex      -- ^ normal case+    | NoVertex    -- ^ exclude this type from the graph+    | Sink        -- ^ out degree zero - don't create any outgoing edges+    | Divert typ  -- ^ replace all outgoing edges with an edge to an alternate type+    | Extra typ   -- ^ add an extra outgoing edge to the given type+    deriving Show++instance Default (VertexStatus typ) where+    def = Vertex++-- | Return the set of types embedded in the given type.  This is just+-- the nodes of the type graph.  The type aliases are expanded by the+-- th-desugar package to make them suitable for use as map keys.+typeGraphVertices :: DsMonad m =>+                     (Type -> m (VertexStatus Type))+                  -> [Type]+                  -> m (Set Type)+typeGraphVertices augment types =+    (Set.fromList . Map.keys) <$> typeGraphEdges augment types++typeGraphEdges+    :: forall m. DsMonad m =>+       (Type -> m (VertexStatus Type))+           -- ^ This function is applied to every expanded type before+           -- use, and the result is used instead.  If it returns+           -- NoVertex, no vertices or edges are added to the graph.+           -- If it returns Sink no outgoing edges are added.  The+           -- current use case Substitute is to see if there is an+           -- instance of class @View a b@ where @a@ is the type+           -- passed to @doType@, and replace it with @b@, and use the+           -- lens returned by @View's@ method to convert between @a@+           -- and @b@ (i.e. to implement the edge in the type graph.)+    -> [Type]+    -> m (TypeGraphEdges Type)++typeGraphEdges augment types = do+  execStateT (mapM_ doNode types) mempty+    where+      doNode :: Type -> StateT (TypeGraphEdges Type) m ()+      doNode typ = do+        mp <- get+        status <- lift (augment typ)+        case Map.lookup typ mp of+          Just _ -> return ()+          Nothing ->+            case status of+              NoVertex -> return ()+              Sink -> addNode typ+              (Divert typ') -> addNode typ >> addEdge typ typ' >> doNode typ'+              (Extra typ') -> addNode typ >> doEdges typ >> addEdge typ typ' >> doNode typ'+              Vertex -> addNode typ >> doEdges typ++      addNode :: Type -> StateT (TypeGraphEdges Type) m ()+      -- addNode a = expandType a >>= \ a' -> modify $ Map.insertWith (flip const) a' Set.empty+      addNode a = modify $ Map.alter (maybe (Just Set.empty) Just) a+      addEdge :: Type -> Type -> StateT (TypeGraphEdges Type) m ()+      addEdge a b = modify $ Map.update (Just . Set.insert b) a++      -- We know that the Type argument is actually fully expanded here.+      doEdges :: Type -> StateT (TypeGraphEdges Type) m ()+      doEdges typ@(ForallT _ _ typ') = addEdge typ typ' >> doNode typ'+      doEdges typ@(AppT container element) =+          addEdge typ container >>+          addEdge typ element >>+          doNode container >>+          doNode element+      -- Can this happen if typ is fully expanded?+      doEdges typ@(ConT name) = do+        info <- qReify name+        case info of+          TyConI dec -> doDec dec+          _ -> return ()+          where+            doDec :: Dec -> StateT (TypeGraphEdges Type) m ()+            doDec dec@(NewtypeD _ tname _ con _) = doCon tname dec con+            doDec dec@(DataD _ tname _ cons _) = mapM_ (doCon tname dec) cons+            doDec (TySynD _tname _tvars typ') = addEdge typ typ' >> doNode typ'+            doDec _ = return ()++            doCon :: Name -> Dec -> Con -> StateT (TypeGraphEdges Type) m ()+            doCon tname dec (ForallC _ _ con) = doCon tname dec con+            doCon tname dec (NormalC cname fields) = mapM_ (doField tname dec cname) (zip (map Left ([1..] :: [Int])) (map snd fields))+            doCon tname dec (RecC cname fields) = mapM_ (doField tname dec cname) (map (\ (fname, _, typ') -> (Right fname, typ')) fields)+            doCon tname dec (InfixC (_, lhs) cname (_, rhs)) = mapM_ (doField tname dec cname) [(Left 1, lhs), (Left 2, rhs)]++            doField _tname _dec _cname (_fld, ftype) = addEdge typ ftype >> doNode ftype++      doEdges _typ = return ({-trace ("Unrecognized type: " ++ pprint' typ)-} ())++-- | Build a graph from the result of typeGraphEdges, each edge goes+-- from a type to one of the types it contains.  Thus, each edge+-- represents a primitive lens, and each path in the graph is a+-- composition of lenses.+typeGraph :: (DsMonad m, node ~ Type, key ~ Type) =>+                (Type -> m (VertexStatus Type)) -> [Type] -> m (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)+typeGraph augment types = do+  typeGraphEdges augment types >>= return . graphFromEdges . triples+    where+      triples mp = map (\ (k, ks) -> (k, k, Set.toList ks)) $ Map.toList mp++{-+type FieldType = (Int, Either StrictType VarStrictType)++-- | The information required to extact a field value from a value.+-- We keep a stack of these as we traverse a declaration.  Generally,+-- we only need the field names.+data StackElement = StackElement FieldType Con Dec deriving (Eq, Show, Data, Typeable)++class Monad m => HasStack m where+    withStack :: ([StackElement] -> m a) -> m a -- Better name: askStack+    push :: FieldType -> Con -> Dec -> m a -> m a -- Better name: localStack++instance (Quasi m, Monoid w) => HasStack (RWST [StackElement] w s m) where+    withStack f = ask >>= f+    push fld con dec action = local (\ stk -> StackElement fld con dec : stk) action++instance HasStack m => HasStack (StateT s m) where+    withStack f = lift (withStack return) >>= f+    push fld con dec action = get >>= \ st -> lift $ push fld con dec (evalStateT action st)++instance Quasi m => HasStack (ReaderT [StackElement] m) where+    withStack f = ask >>= f+    push fld con dec action = local (\ stk -> StackElement fld con dec : stk) action++instance (HasStack m, Monoid w) => HasStack (WriterT w m) where+    withStack f = lift (withStack return) >>= f+    push fld con dec action =+        do (r, w') <- lift $ push fld con dec (runWriterT action)+           tell w'+           return r++prettyStack :: [StackElement] -> String+prettyStack = prettyStack' . reverse+    where+      prettyStack' :: [StackElement] -> String+      prettyStack' [] = "(empty)"+      prettyStack' (x : xs) = "[" ++ prettyElt x ++ prettyTail xs ++ "]"+      prettyTail [] = ""+      prettyTail (x : xs) = " → " ++ prettyElt x ++ prettyTail xs+      prettyElt (StackElement fld con dec) =+          foldDec prettyType (\ _ -> nameBase (decName dec)) dec ++ ":" +++          foldCon (\ name _ -> nameBase name) con ++ "." +++          prettyField fld+      prettyType typ = foldTypeP nameBase+                                 (\ t1 t2 -> "((" ++ prettyType t1 ++ ") (" ++ prettyType t2 ++ "))")+                                 ("(" ++ show typ ++ ")")+                                 typ++type StackT m = ReaderT [StackElement] m++execStackT :: Monad m => StackT m a -> m a+execStackT action = runReaderT action []++-- | Combine a decFn and a primFn to make a nameFn in the Quasi monad.+-- This is used to build the first argument to the foldType function+-- when we need to know whether the name refers to a declared or a+-- primitive type.+foldName :: Quasi m =>+            (Dec -> m r)+         -> (Name -> Int -> Bool -> m r)+         -> (Info -> m r)+         -> Name -> m r+foldName decFn primFn otherFn name = do+  info <- qReify name+  case info of+    (TyConI dec) ->+        decFn dec+    (PrimTyConI a b c) -> primFn a b c+    _ -> otherFn info++-- | Dispatch on the different constructors of the Dec type.+foldDec :: Monad m =>+           (Type -> m r)+        -> ([Con] -> m r)+        -> Dec -> m r+foldDec typeFn shapeFn dec =+    case dec of+      TySynD _name _ typ -> typeFn typ+      NewtypeD _ _ _ con _ -> shapeFn [con]+      DataD _ _ _ cons _ -> shapeFn cons+      _ -> error $ "foldDec - unexpected: " ++ show dec++decName :: Dec -> Name+decName (NewtypeD _ name _ _ _) = name+decName (DataD _ name _ _ _) = name+decName (TySynD name _ _) = name+decName x = error $ "decName - unimplemented: " ++ show x++-- | Deconstruct a constructor+foldCon :: (Name -> [FieldType] -> r) -> Con -> r+foldCon fldFn (NormalC name ts) = fldFn name $ zip [1..] (map Left ts)+foldCon fldFn (RecC name ts) = fldFn name (zip [1..] (map Right ts))+foldCon fldFn (InfixC t1 name t2) = fldFn name [(1, Left t1), (2, Left t2)]+foldCon fldFn (ForallC _ _ con) = foldCon fldFn con++prettyField :: FieldType -> String+prettyField fld = maybe (show (fPos fld)) nameBase (fName fld)++-- | Pure version of foldType.+foldTypeP :: (Name -> r) -> (Type -> Type -> r) -> r -> Type -> r+foldTypeP nfn afn ofn typ = runIdentity $ foldType (\ n -> Identity $ nfn n) (\ t1 t2 -> Identity $ afn t1 t2) (Identity ofn) typ++fPos :: FieldType -> Int+fPos (n, _) = n++fName :: FieldType -> Maybe Name+fName (_, (Left _)) = Nothing+fName (_, (Right (name, _, _))) = Just name++-- | Dispatch on the constructors of type Type.  This ignores the+-- "ForallT" constructor, it just uses the embeded Type field.+foldType :: Monad m => (Name -> m r) -> (Type -> Type -> m r) -> m r -> Type -> m r+foldType nfn afn ofn (ForallT _ _ typ) = foldType nfn afn ofn typ+foldType nfn _ _ (ConT name) = nfn name+foldType _ afn _ (AppT t1 t2) = afn t1 t2+foldType _ _ ofn _ = ofn+-}++{-+adjacentTypes :: DsMonad m => Type -> m (Type, [Type])+adjacentTypes (ForallT _ _ typ) = adjacentTypes typ+adjacentTypes (AppT t1 t2) = [t1, t2]+adjacentTypes t@(ConT _) = [t]+adjacentTypes t@(VarT _) = [t]+adjacentTypes _ = []+-}
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main :: IO ()+main = defaultMain
+ test/Common.hs view
@@ -0,0 +1,39 @@+module Common where++import Data.List as List (map)+import Data.Map as Map (toList)+import Data.Set as Set (Set, difference, empty, toList)+import Data.Generics (Data, everywhere, mkT)+import Language.Haskell.TH+import Language.Haskell.TH.Context.Helpers (pprint')+import Language.Haskell.TH.TypeGraph (TypeGraphEdges)++data SetDifferences a = SetDifferences {extra :: Set a, missing :: Set a} deriving (Eq, Ord, Show)++setDifferences :: Ord a => Set a -> Set a -> SetDifferences a+setDifferences actual expected = SetDifferences {extra = Set.difference actual expected, missing = Set.difference expected actual}+noDifferences = SetDifferences {extra = Set.empty, missing = Set.empty}++unReify :: Data a => a -> a+unReify = everywhere (mkT unReifyName)++unReifyName :: Name -> Name+unReifyName = mkName . nameBase++-- Some very nasty bug is triggered here in ghc-7.8 if we try to implement+-- a generic function that unReifies the symbols.  Ghc-7.10 works fine++-- pprint'' :: (Data a, Ppr a) => a -> String+-- pprint'' = pprint' . unReify++pprintDec :: Dec -> String+pprintDec = pprint' . unReify++pprintType :: Type -> String+pprintType = pprint' . unReify++pprintPred :: Pred -> String+pprintPred = pprint' . unReify++edgesToStrings :: TypeGraphEdges Type -> [(String, [String])]+edgesToStrings mp = List.map (\ (t, ts) -> (pprintType t, map pprintType (Set.toList ts))) (Map.toList mp)
+ test/Context.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall #-}+module Context where++import Control.DeepSeq+import Data.Array.IArray+import Data.Array.Unboxed+import Data.Bits+import Data.List as List (map, null)+import Data.Map as Map (Map, map, mapKeys, toList, fromList)+import Data.Set as Set (Set, fromList)+import Language.Haskell.TH+import Language.Haskell.TH.Context (reifyInstancesWithContext, runContext)+import Language.Haskell.TH.Context.Expand (expandType)+import Language.Haskell.TH.Context.Helpers (pprint')+import Language.Haskell.TH.Context.Simple (missingInstances, simpleMissingInstanceTest)+import Language.Haskell.TH.Desugar (withLocalDeclarations)+import Language.Haskell.TH.Syntax (Lift(lift), Quasi(qReifyInstances))+import System.Exit (ExitCode)+import Test.Hspec hiding (runIO)+import Test.Hspec.Core.Spec (SpecM)++import Common+import Values++tests :: SpecM () ()+tests = do+  it "can run the Q monad" $ do+     typ <- runQ [t|Int|]+     typ `shouldBe` ConT ''Int++  -- String becomes [Char], Maybe String becomes Maybe [Char], Maybe (Maybe String) becomes Maybe (Maybe [Char])+  it "expands types as expected" $ do+     (expected :: [Type]) <- runQ (sequence [ [t| [Char] |], [t|Maybe [Char] |], [t|Maybe (Maybe [Char])|] ])+     let expanded = $(withLocalDeclarations [] (do (types :: [Type]) <- runQ (sequence [ [t|String|], [t|Maybe String|], [t|Maybe (Maybe String)|] ]) >>= mapM expandType+                                                   runQ . lift $ types))+     expanded `shouldBe` expected++  -- Test the behavior of th-reify-many+  it "can tell that there is an instance NFData Char" $+     $(do insts <- qReifyInstances ''NFData [ConT ''Char]+          lift $ List.map pprint' insts) `shouldBe` (["instance Control.DeepSeq.NFData GHC.Types.Char"] :: [String])++  it "can tell that there is no instance NFData ExitCode" $+     $(do insts <- qReifyInstances ''NFData [ConT ''ExitCode]+          lift $ List.map pprint' insts) `shouldBe` ([] :: [String])++  it "can tell that an instance hasn't been declared" $+     $(missingInstances simpleMissingInstanceTest [d|instance NFData ExitCode|] >>= lift . List.null)+          `shouldBe` False++  it "can tell that an instance has been declared" $+     $(missingInstances simpleMissingInstanceTest [d|instance NFData Char|] >>= lift . List.null)+          `shouldBe` True++-- GHCs older than 7.10 that haven't been specially patched cannot deal with+-- the unbound type variable a.+#if __GLASGOW_HASKELL__ >= 709 || defined(PATCHED_FOR_TRAC_9262)+  -- Doesn't actually use any th-context functions, but it tests+  -- for trac 9262.+  it "Is using a ghc without bug https://ghc.haskell.org/trac/ghc/ticket/9262 (i.e. either 7.10 or a custom patched ghc)" $ do+     $(do insts <- qReifyInstances ''Eq [ListT `AppT` VarT (mkName "a")]+          -- runIO $ putStrLn (pprint insts)+          lift "ok")+         `shouldBe` "ok"++  it "can find all the Bits instances" $ do+     (setDifferences+        (Set.fromList+           $(do insts <- qReifyInstances ''Bits [VarT (mkName "a")]+                lift (List.map pprintDec insts)))+        bitsInstances)+      `shouldBe` noDifferences+{-+  it "can match all the Enum instances" $ do+     (\ (insts, _pairs) -> (setDifferences (Set.fromList insts) enumInstances))+             $(do (insts, mp) <- runContext (reifyInstancesWithContext ''Enum [VarT (mkName "a")])+                  lift (List.map pprintDec insts, Map.toList (Map.map (List.map pprintDec) (Map.mapKeys pprintPred mp))))+          `shouldBe` noDifferences+-}+  it "can handle multi param class IArray" $ do+     (\ (insts, pairs) -> (setDifferences (Set.fromList insts) arrayInstances,+                           Map.map Set.fromList (Map.fromList pairs)))+             -- Unquote the template haskell Q monad expression+             $(do -- Run instances and save the result and the state monad result+                  (insts, mp) <- runContext (reifyInstancesWithContext ''IArray [ConT ''UArray, VarT (mkName "a")])+                  -- Convert to lists of text so we can lift out of Q+                  lift (List.map pprintDec insts, Map.toList (Map.map (List.map pprintDec) (Map.mapKeys pprintPred mp))))+          `shouldBe` (noDifferences,+                      -- I don't think this is right+                      Map.fromList [{-("Data.Array.Base.IArray Data.Array.Base.UArray a", arrayInstances)-}] :: Map String (Set String))+#endif
+ test/Tests.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+module Main where++import Control.DeepSeq+import Control.Monad.State (evalStateT, runStateT)+import Data.Array.Base+import Data.ByteString (ByteString)+import Data.List as List (intercalate, map, null)+import Data.Map as Map (Map, fromList, toList, map, mapKeys, empty)+import Data.Set as Set (Set, fromList, toList, null, difference, empty)+import Data.Text (Text)+import Data.Monoid (mempty)+import Language.Haskell.TH+import Language.Haskell.TH.Context (reifyInstancesWithContext)+import Language.Haskell.TH.Context.Simple (missingInstances, simpleMissingInstanceTest)+import Language.Haskell.TH.Desugar (withLocalDeclarations)+import Language.Haskell.TH.ReifyMany+import Language.Haskell.TH.Syntax (Lift(lift), Quasi(qReifyInstances))+import System.Exit (ExitCode)+import Test.Hspec hiding (runIO)+import Context (tests)+import TypeGraph (tests)++main :: IO ()+main = hspec $ do+  TypeGraph.tests+  Context.tests
+ test/TypeGraph.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall #-}+module TypeGraph where++import Control.Monad (filterM)+--import Data.Map as Map (toList)+import Data.Set as Set (fromList, toList)+--import GHC.Prim -- ByteArray#, Char#, etc+import Language.Haskell.TH+import Language.Haskell.TH.Desugar (withLocalDeclarations)+import Language.Haskell.TH.Context.Expand (expandType)+import Language.Haskell.TH.Context.Helpers (typeArity)+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.TypeGraph (typeGraphVertices, typeGraphEdges, VertexStatus(Vertex))+import Test.Hspec hiding (runIO)+import Test.Hspec.Core.Spec (SpecM)++import Common+import Values++tests :: SpecM () ()+tests = do+  it "can find the subtypes of Type" $ do+     setDifferences (fromList $(withLocalDeclarations [] $+                                  runQ [t|Type|] >>=+                                  expandType >>= \ (typ :: Type) ->+                                  typeGraphVertices (const $ return Vertex) [typ] >>=+                                  runQ . lift . map pprintType . Set.toList)) subtypesOfType+        `shouldBe` noDifferences++  it "can find the edges of the subtype graph of Type" $ do+     setDifferences (fromList $(withLocalDeclarations [] $+                                runQ [t|Type|] >>=+                                expandType >>= \ (typ :: Type) ->+                                typeGraphEdges (const $ return Vertex) [typ] >>=+                                runQ . lift . edgesToStrings)) typeEdges+        `shouldBe` noDifferences++  it "can find the edges of the subtype graph of Dec" $ do+     setDifferences (fromList $(withLocalDeclarations [] $+                                runQ [t|Dec|] >>=+                                expandType >>= \ (typ :: Type) ->+                                typeGraphEdges (const $ return Vertex) [typ] >>=+                                runQ . lift . edgesToStrings)) decEdges+        `shouldBe` noDifferences++  it "can find the subtypes of Dec" $ do+     setDifferences (fromList $(withLocalDeclarations [] $+                                runQ [t|Dec|] >>=+                                expandType >>= \ (typ :: Type) ->+                                typeGraphVertices (const $ return Vertex) [typ] >>=+                                runQ . lift . map pprintType . Set.toList)) subtypesOfDec+        `shouldBe` noDifferences++  it "can find the arity 0 subtypes of Dec" $ do+     setDifferences (fromList $(withLocalDeclarations [] $+                                runQ [t|Dec|] >>=+                                expandType >>= \ (typ :: Type) ->+                                typeGraphVertices (const $ return Vertex) [typ] >>=+                                filterM (\ t -> typeArity t >>= \ a -> return (a == 0)) . Set.toList >>=+                                runQ . lift . map pprintType)) arity0SubtypesOfDec+        `shouldBe` noDifferences
+ test/Values.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+module Values where++import Control.Monad (filterM)+import Data.Map as Map (toList)+import Data.Set as Set (Set, fromList, toList, union)+import GHC.Prim -- ByteArray#, Char#, etc+import Language.Haskell.TH+import Language.Haskell.TH.Desugar (withLocalDeclarations)+import Language.Haskell.TH.Context.Expand (expandType)+import Language.Haskell.TH.Context.Helpers (typeArity)+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.TypeGraph (typeGraphVertices, typeGraphEdges, VertexStatus(Vertex))+import Test.Hspec hiding (runIO)+import Test.Hspec.Core.Spec (SpecM)++import Common++subtypesOfType :: Set String+subtypesOfType =+    fromList+    [+#if MIN_VERSION_template_haskell(2,10,0)+      "BigNat",+#else+      "[Type]",+#endif+      "ByteArray#","Char","Char#","Cxt","Int","Int#","Integer","Kind","ModName","Name","NameFlavour","NameSpace","OccName","PkgName","Pred","String","TyLit","TyVarBndr","Type","[Char]","[Pred]","[TyVarBndr]", "[]" ]++decEdges :: Set (String, [String])+decEdges =+    fromList+      [+#if MIN_VERSION_template_haskell(2,10,0)+       ("BigNat",["ByteArray#"]),+       ("Integer",["Int#","BigNat"]),+       ("NameFlavour",["Int","ModName","NameSpace","PkgName"]),+       ("Pragma",["Maybe Inline","[RuleBndr]","String","Int","AnnTarget","Exp","Inline","Name","Phases","RuleMatch","Type"]),+       ("Pred",["Type"]),+#else+       ("Integer",["ByteArray#","Int#"]),+       ("NameFlavour",["Int#","ModName","NameSpace","PkgName"]),+       ("Pragma",["Maybe Inline","[RuleBndr]","String","AnnTarget","Exp","Inline","Name","Phases","RuleMatch","Type"]),+       ("Pred",["[Type]","Name","Type"]),+#endif+       ("(,)",[]),("(,,)",[]),("[]",[]),("(,) Guard",["Guard","(,)"]),("(,) Name",["Name","(,)"]),("(,) Strict",["Strict","(,)"]),("(,,) Name",["Name","(,,)"]),("(,,) Name Strict",["(,,) Name","Strict"]),("(Guard, Exp)",["(,) Guard","Exp"]),("(Name, Exp)",["(,) Name","Exp"]),("(Name, Pat)",["(,) Name","Pat"]),("(Name, Strict, Type)",["(,,) Name Strict","Type"]),("(Strict, Type)",["(,) Strict","Type"]),("AnnTarget",["Name"]),("Body",["[(Guard, Exp)]","Exp"]),("ByteArray#",[]),("Callconv",[]),("Char",["Char#"]),("Char#",[]),("Clause",["[Dec]","[Pat]","Body"]),("Con",["[StrictType]","[TyVarBndr]","[VarStrictType]","Con","Cxt","Name","StrictType"]),("Cxt",["[Pred]"]),("Dec",["Maybe Kind","[Clause]","[Con]","[Dec]","[FunDep]","[Name]","[Role]","[TySynEqn]","[TyVarBndr]","[Type]","Body","Con","Cxt","FamFlavour","Fixity","Foreign","Name","Pat","Pragma","TySynEqn","Type"]),("Exp",["Maybe Exp","[(Guard, Exp)]","[Dec]","[Exp]","[FieldExp]","[Match]","[Pat]","[Stmt]","Exp","Lit","Name","Range","Type"]),("FamFlavour",[]),("FieldExp",["(Name, Exp)"]),("FieldPat",["(Name, Pat)"]),("Fixity",["Int","FixityDirection"]),("FixityDirection",[]),("Foreign",["String","Callconv","Name","Safety","Type"]),("FunDep",["[Name]"]),("Guard",["[Stmt]","Exp"]),("Inline",[]),("Int",["Int#"]),("Int#",[]),("Kind",["Type"]),("Lit",["[Word8]","String","Rational","Char","Integer"]),("Match",["[Dec]","Body","Pat"]),("Maybe",["a"]),("Maybe Exp",["Maybe","Exp"]),("Maybe Inline",["Maybe","Inline"]),("Maybe Kind",["Maybe","Kind"]),("ModName",["String"]),("Name",["NameFlavour","OccName"]),("NameSpace",[]),("OccName",["String"]),("Pat",["[FieldPat]","[Pat]","Exp","Lit","Name","Pat","Type"]),("Phases",["Int"]),("PkgName",["String"]),("Range",["Exp"]),("Ratio",["a"]),("Ratio Integer",["Ratio","Integer"]),("Rational",["Ratio Integer"]),("Role",[]),("RuleBndr",["Name","Type"]),("RuleMatch",[]),("Safety",[]),("Stmt",["[[Stmt]]","[Dec]","Exp","Pat"]),("Strict",[]),("StrictType",["(Strict, Type)"]),("String",["[Char]"]),("TyLit",["String","Integer"]),("TySynEqn",["[Type]","Type"]),("TyVarBndr",["Kind","Name"]),("Type",["[TyVarBndr]","Int","Cxt","Kind","Name","TyLit","Type"]),("VarStrictType",["(Name, Strict, Type)"]),("Word#",[]),("Word8",["Word#"]),("[(Guard, Exp)]",["(Guard, Exp)","[]"]),("[Char]",["Char","[]"]),("[Clause]",["Clause","[]"]),("[Con]",["Con","[]"]),("[Dec]",["Dec","[]"]),("[Exp]",["Exp","[]"]),("[FieldExp]",["FieldExp","[]"]),("[FieldPat]",["FieldPat","[]"]),("[FunDep]",["FunDep","[]"]),("[Match]",["Match","[]"]),("[Name]",["Name","[]"]),("[Pat]",["Pat","[]"]),("[Pred]",["Pred","[]"]),("[Role]",["Role","[]"]),("[RuleBndr]",["RuleBndr","[]"]),("[Stmt]",["Stmt","[]"]),("[StrictType]",["StrictType","[]"]),("[TySynEqn]",["TySynEqn","[]"]),("[TyVarBndr]",["TyVarBndr","[]"]),("[Type]",["Type","[]"]),("[VarStrictType]",["VarStrictType","[]"]),("[Word8]",["Word8","[]"]),("[[Stmt]]",["[Stmt]","[]"]),("a",[])]++typeEdges :: Set (String, [String])+typeEdges =+    fromList+      [+#if MIN_VERSION_template_haskell(2,10,0)+       ("BigNat",["ByteArray#"]),+       ("Integer",["Int#","BigNat"]),+       ("NameFlavour",["Int","ModName","NameSpace","PkgName"]),("Pred",["Type"]),+#else+       ("Integer",["ByteArray#","Int#"]),+       ("NameFlavour",["Int#","ModName","NameSpace","PkgName"]),+       ("Pred",["[Type]","Name","Type"]),("[Type]",["Type","[]"]),+#endif+       ("[]",[]),("ByteArray#",[]),("Char",["Char#"]),("Char#",[]),("Cxt",["[Pred]"]),("Int",["Int#"]),("Int#",[]),("Kind",["Type"]),("ModName",["String"]),("Name",["NameFlavour","OccName"]),("NameSpace",[]),("OccName",["String"]),("PkgName",["String"]),("String",["[Char]"]),("TyLit",["String","Integer"]),("TyVarBndr",["Kind","Name"]),("Type",["[TyVarBndr]","Int","Cxt","Kind","Name","TyLit","Type"]),("[Char]",["Char","[]"]),("[Pred]",["Pred","[]"]),("[TyVarBndr]",["TyVarBndr","[]"])]++arity0SubtypesOfDec :: Set String+arity0SubtypesOfDec =+    fromList+         [+#if MIN_VERSION_template_haskell(2,10,0)+           "BigNat",+#endif+           "(Guard, Exp)","(Name, Exp)","(Name, Pat)","(Name, Strict, Type)","(Strict, Type)","AnnTarget","Body","ByteArray#","Callconv","Char","Char#","Clause","Con","Cxt","Dec","Exp","FamFlavour","FieldExp","FieldPat","Fixity","FixityDirection","Foreign","FunDep","Guard","Inline","Int","Int#","Integer","Kind","Lit","Match","Maybe Exp","Maybe Inline","Maybe Kind","ModName","Name","NameFlavour","NameSpace","OccName","Pat","Phases","PkgName","Pragma","Pred","Range","Ratio Integer","Rational","Role","RuleBndr","RuleMatch","Safety","Stmt","Strict","StrictType","String","TyLit","TySynEqn","TyVarBndr","Type","VarStrictType","Word#","Word8","[(Guard, Exp)]","[Char]","[Clause]","[Con]","[Dec]","[Exp]","[FieldExp]","[FieldPat]","[FunDep]","[Match]","[Name]","[Pat]","[Pred]","[Role]","[RuleBndr]","[Stmt]","[StrictType]","[TySynEqn]","[TyVarBndr]","[Type]","[VarStrictType]","[Word8]","[[Stmt]]" ]+++subtypesOfDec :: Set String+subtypesOfDec =+    union+       arity0SubtypesOfDec+       (fromList+          [+           "a",+           "Maybe",+           "Ratio",+           "(,) Guard",+           "(,) Name",+           "(,) Strict",+           "(,,) Name",+           "(,,) Name Strict",+           "(,,)",+           "(,)",+           "[]"])++bitsInstances :: Set String+bitsInstances+    = Set.fromList+       [+#if MIN_VERSION_template_haskell(2,10,0)+        "instance Bits CChar","instance Bits CInt","instance Bits CIntMax","instance Bits CIntPtr","instance Bits CLLong","instance Bits CLong","instance Bits CPtrdiff","instance Bits CSChar","instance Bits CShort","instance Bits CSigAtomic","instance Bits CSize","instance Bits CUChar","instance Bits CUInt","instance Bits CUIntMax","instance Bits CUIntPtr","instance Bits CULLong","instance Bits CULong","instance Bits CUShort","instance Bits CWchar",+#endif+        "instance Bits Bool","instance Bits Int","instance Bits Integer","instance Bits Word","instance Bits Word16","instance Bits Word32","instance Bits Word64","instance Bits Word8",+        -- These come and go depending on the version of something.+        "instance Bits Int16","instance Bits Int32","instance Bits Int64","instance Bits Int8","instance Bits Natural" ]++enumInstances :: Set String+enumInstances =+    Set.fromList+    [+#if MIN_VERSION_template_haskell(2,10,0)+     "instance Enum (Fixed a)","instance Enum (Proxy s)","instance Enum (f a) => Enum (Alt f a)","instance Enum CChar","instance Enum CClock","instance Enum CDouble","instance Enum CFloat","instance Enum CInt","instance Enum CIntMax","instance Enum CIntPtr","instance Enum CLLong","instance Enum CLong","instance Enum CPtrdiff","instance Enum CSChar","instance Enum CSUSeconds","instance Enum CShort","instance Enum CSigAtomic","instance Enum CSize","instance Enum CTime","instance Enum CUChar","instance Enum CUInt","instance Enum CUIntMax","instance Enum CUIntPtr","instance Enum CULLong","instance Enum CULong","instance Enum CUSeconds","instance Enum CUShort","instance Enum CWchar","instance Enum Day","instance Enum NominalDiffTime",+#endif+     "instance Enum ()","instance Enum Bool","instance Enum Char","instance Enum Double","instance Enum Float","instance Enum Int","instance Enum Int16","instance Enum Int32","instance Enum Int64","instance Enum Int8","instance Enum Integer","instance Enum Natural","instance Enum Ordering","instance Enum Word","instance Enum Word16","instance Enum Word32","instance Enum Word64","instance Enum Word8","instance Integral a => Enum (Ratio a)"]++arrayInstances :: Set String+arrayInstances =+    Set.fromList ["instance IArray UArray (FunPtr a)","instance IArray UArray (Ptr a)","instance IArray UArray (StablePtr a)","instance IArray UArray Bool","instance IArray UArray Char","instance IArray UArray Double","instance IArray UArray Float","instance IArray UArray Int","instance IArray UArray Int16","instance IArray UArray Int32","instance IArray UArray Int64","instance IArray UArray Int8","instance IArray UArray Word","instance IArray UArray Word16","instance IArray UArray Word32","instance IArray UArray Word64","instance IArray UArray Word8"]
+ th-context.cabal view
@@ -0,0 +1,58 @@+name:               th-context+version:            0.13+cabal-version:      >= 1.10+build-type:         Simple+license:            BSD3+category:           Template Haskell+author:             David Fox+copyright:          (c) David Fox+maintainer:         David Fox <dsf@seereason.com>+homepage:           https://github.com/seereason/th-context+bug-reports:        https://github.com/seereason/th-context/issues+stability:          experimental+synopsis:           Test instance context+description:        Use these functions to decide an a not-quite naive fashion+                    whether an instance already exists that satisfies a given+                    context.  This can be used to decide whether an instance+                    needs to be generated, as in th-reify-many.+extra-source-files: test/Common.hs test/Context.hs test/Tests.hs test/TypeGraph.hs test/Values.hs++flag patched-for-trac-9262+  Description: This can be turned on if ghc-7.8 has had a patch applied to fix issue 9262+  Default: True++library+  build-depends:+    base >= 4.2 && < 5,+    containers,+    data-default,+    haskell-src-exts,+    mtl,+    syb,+    template-haskell >= 2.9,+    th-desugar,+    th-orphans >= 0.10.0+  ghc-options:      -Wall+  exposed-modules:  Language.Haskell.TH.Context,+                    Language.Haskell.TH.Context.Expand,+                    Language.Haskell.TH.Context.Helpers,+                    Language.Haskell.TH.Context.Simple,+                    Language.Haskell.TH.TypeGraph+  default-language: Haskell2010+  if flag(patched-for-trac-9262)+    cpp-options:      -DPATCHED_FOR_TRAC_9262++test-suite th-context-tests+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Tests.hs+  build-depends:    array, base, bytestring, containers, deepseq, ghc-prim,+                    hspec, hspec-core, mtl, syb, template-haskell, text,+                    th-context, th-desugar, th-orphans, th-reify-many+  default-language: Haskell2010+  if flag(patched-for-trac-9262)+    cpp-options:      -DPATCHED_FOR_TRAC_9262++source-repository head+  type:     git+  location: git://github.com/seereason/th-context.git