packages feed

th-typegraph 0.23 → 0.24

raw patch · 18 files changed

+629/−616 lines, 18 filesdep −memoize

Dependencies removed: memoize

Files

+ Language/Haskell/TH/TypeGraph/Arity.hs view
@@ -0,0 +1,32 @@+-- | Function to compute the arity or kind of a Type, the number of+-- type parameters that need to be applied to get a concrete type.+module Language.Haskell.TH.TypeGraph.Arity+    ( typeArity+    ) where++import Language.Haskell.TH+import Language.Haskell.TH.Desugar ({- instances -})+import Language.Haskell.TH.Syntax (Quasi(qReify))+import Language.Haskell.TH.TypeGraph.Prelude (pprint')++-- | Compute the arity of a type - the number of type parameters that+-- must be applied to it in order to obtain a concrete type.  I'm not+-- quite sure I understand the relationship between this and 'freeTypeVars'.+typeArity :: Quasi m => Type -> m Int+typeArity (ForallT _ _ typ) = typeArity typ -- Shouldn't a forall affect the arity?+typeArity ListT = return 1+typeArity (TupleT n) = return n+typeArity (VarT _) = return 1+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
Language/Haskell/TH/TypeGraph/Edges.hs view
@@ -35,6 +35,7 @@ import Control.Monad (filterM) import Control.Monad.Reader (MonadReader) import Control.Monad.State (execStateT, modify, StateT)+import Control.Monad.Trans (lift) import Data.Foldable import Data.List as List (filter, intercalate, map) import Data.Map as Map ((!), alter, delete, filterWithKey, fromList, keys, lookup, map, Map, mapKeysWith, mapWithKey)@@ -45,8 +46,9 @@ import Language.Haskell.TH -- (Con, Dec, nameBase, Type) import Language.Haskell.TH.PprLib (ptext) import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)-import Language.Haskell.TH.TypeGraph.Info (TypeInfo, infoMap, typeSet, allVertices, fieldVertex, typeVertex')+import Language.Haskell.TH.TypeGraph.HasState (HasState) import Language.Haskell.TH.TypeGraph.Prelude (pprint')+import Language.Haskell.TH.TypeGraph.TypeInfo (TypeInfo, infoMap, typeSet, allVertices, fieldVertex, typeVertex') import Language.Haskell.TH.TypeGraph.Vertex (TGV, TGVSimple, vsimple) import Language.Haskell.TH.Desugar as DS (DsMonad) import Language.Haskell.TH.Instances ()@@ -58,10 +60,9 @@ -- fields, build and return the GraphEdges relation on TypeGraphVertex. -- This is not a recursive function, it stops when it reaches the field -- types.-typeGraphEdges :: forall m. (DsMonad m, Functor m, MonadReader TypeInfo m) =>-                  m (GraphEdges TGV)+typeGraphEdges :: forall m. (DsMonad m, Functor m, MonadReader TypeInfo m, HasState (Map Type (E Type)) m) => m (GraphEdges TGV) typeGraphEdges = do-  execStateT (view typeSet >>= mapM_ (\t -> expandType t >>= doType)) mempty+  execStateT (view typeSet >>= mapM_ (\t -> lift (expandType t) >>= doType)) mempty     where       doType :: E Type -> StateT (GraphEdges TGV) m ()       doType typ = do@@ -98,8 +99,8 @@       -- Connect the vertex for this record type to one particular field vertex       doField ::  DsMonad m => Set TGV -> Name -> Name -> Either Int Name -> Type -> StateT (GraphEdges TGV) m ()       doField vs tname cname fld ftyp = do-        v2 <- expandType ftyp >>= fieldVertex (tname, cname, fld)-        v3 <- expandType ftyp >>= typeVertex'+        v2 <- lift (expandType ftyp) >>= fieldVertex (tname, cname, fld)+        v3 <- lift (expandType ftyp) >>= typeVertex'         edge v2 v3         mapM_ (flip edge v2) vs         -- Here's where we don't recurse, see?
Language/Haskell/TH/TypeGraph/Expand.hs view
@@ -22,82 +22,50 @@ {-# LANGUAGE TemplateHaskell #-}  module Language.Haskell.TH.TypeGraph.Expand-    ( Expanded(markExpanded, runExpanded')-    , runExpanded+    ( E(E, unE)+    , ExpandMap     , expandType     , expandPred     , expandClassP-    , E(E)     ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Data.Function.Memoize (deriveMemoizable, memoize)+-- import Data.Function.Memoize (deriveMemoizable, memoize)+import Data.Map as Map (Map, lookup, insert) 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 Language.Haskell.TH.Syntax -- (Lift(lift))+import Language.Haskell.TH.TypeGraph.HasState (HasState(getState, modifyState)) import Prelude hiding (pred) -$(deriveMemoizable ''Type)-$(deriveMemoizable ''Name)-$(deriveMemoizable ''TyLit)-$(deriveMemoizable ''NameFlavour)-$(deriveMemoizable ''OccName)-$(deriveMemoizable ''NameSpace)-$(deriveMemoizable ''TyVarBndr)-$(deriveMemoizable ''ModName)-$(deriveMemoizable ''PkgName)+-- | A concrete type used to mark type which have been expanded+newtype E a = E {unE :: a} deriving (Eq, Ord, Show) --- | 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+instance Ppr a => Ppr (E a) where+    ppr (E x) = ppr x +instance Lift (E Type) where+    lift etype = [|E $(lift (unE etype))|]++-- | The state type used to memoize expansions.+type ExpandMap = Map Type (E Type)+ -- | Apply the th-desugar expand function to a 'Type' and mark it as expanded.-expandType :: (DsMonad m, Expanded Type e)  => Type -> m e-expandType = memoize $ \typ -> markExpanded <$> DS.typeToTH <$> (DS.dsType typ >>= DS.expand)+expandType :: (DsMonad m, HasState ExpandMap m)  => Type -> m (E Type)+expandType typ = do+  getState >>= maybe expandType' return . Map.lookup typ+    where+      expandType' =+          do e <- E <$> DS.typeToTH <$> (DS.dsType typ >>= DS.expand)+             modifyState (Map.insert typ e)+             return e  -- | 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 __GLASGOW_HASKELL__ >= 709+expandPred :: (DsMonad m, HasState ExpandMap m)  => Type -> m (E Type) expandPred = expandType-#else-expandPred (ClassP className typeParameters) = expandClassP className typeParameters-expandPred (EqualP type1 type2) = markExpanded <$> (EqualP <$> (runExpanded <$> expandType type1) <*> (runExpanded <$> 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 =-#if __GLASGOW_HASKELL__ >= 709-      (expandType $ foldl AppT (ConT className) typeParameters) :: m e-#else-      (markExpanded . ClassP className . map runExpanded) <$> mapM expandType typeParameters-#endif--runExpanded :: Expanded a (E a) => E a -> a-runExpanded = runExpanded'---- | A concrete type for which Expanded instances are declared below.-newtype E a = E a deriving (Eq, Ord, Show)--instance Expanded Type (E Type) where-    markExpanded = E-    runExpanded' (E x) = x--#if __GLASGOW_HASKELL__ < 709-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--instance Lift (E Type) where-    lift etype = [|markExpanded $(lift (runExpanded etype))|]+expandClassP :: forall m. (DsMonad m, HasState ExpandMap m)  => Name -> [Type] -> m (E Type)+expandClassP className typeParameters = (expandType $ foldl AppT (ConT className) typeParameters) :: m (E Type)
Language/Haskell/TH/TypeGraph/Free.hs view
@@ -1,7 +1,9 @@+-- | Function to compute free type variable set for a Type.  (I took+-- this from somewhere, I really need to credit it.  Now when I search+-- all I can find is myself.) {-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, TemplateHaskell #-} module Language.Haskell.TH.TypeGraph.Free     ( freeTypeVars-    , typeArity     ) where  import Control.Lens hiding (Strict, cons)@@ -21,28 +23,6 @@ st0 = St {_result = empty, _stack = empty}  $(makeLenses ''St)---- | Compute the arity of a type - the number of type parameters that--- must be applied to it in order to obtain a concrete type.  I'm not--- quite sure I understand the relationship between this and 'freeTypeVars'.-typeArity :: Quasi m => Type -> m Int-typeArity (ForallT _ _ typ) = typeArity typ -- Shouldn't a forall affect the arity?-typeArity ListT = return 1-typeArity (TupleT n) = return n-typeArity (VarT _) = return 1-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  -- | Return the names of the type variables that are free in x.  I.e., -- type variables that appear in the type expression but are not bound
− Language/Haskell/TH/TypeGraph/Graph.hs 
@@ -1,263 +0,0 @@--- | Abstract operations on Maps containing graph edges.--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}--module Language.Haskell.TH.TypeGraph.Graph-    ( TypeGraph, typeInfo, edges, graph, gsimple, stack-    , graphFromMap--    , allLensKeys-    , allPathKeys-    , allPathStarts-    , reachableFrom-    , reachableFromSimple-    , goalReachableFull-    , goalReachableSimple-    , goalReachableSimple'--    , makeTypeGraph-    , VertexStatus(..)-    , typeGraphEdges'-    , adjacent-    , typeGraphVertex-    , typeGraphVertexOfField-    ) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-import Data.Monoid (mempty)-#else-import Control.Applicative-#endif-import Control.Lens -- (makeLenses, over, view)-import Control.Monad (when)-import Control.Monad.Reader (ask, local, MonadReader, ReaderT, runReaderT)-import Control.Monad.State (execStateT, modify, StateT)-import Control.Monad.Trans (lift)-import Data.Default (Default(def))-import Data.Foldable as Foldable-import Data.Graph hiding (edges)-import Data.List as List (map)-import Data.Map as Map (alter, fromList, fromListWith, Map, update)-import qualified Data.Map as Map (toList)-import Data.Maybe (fromJust, mapMaybe)-import Data.Set.Extra as Set (empty, fromList, insert, map, member, Set, singleton, toList, union, unions)-import Data.Traversable as Traversable-import Language.Haskell.Exts.Syntax ()-import Language.Haskell.TH-import Language.Haskell.TH.Desugar (DsMonad)-import Language.Haskell.TH.Instances ()-import Language.Haskell.TH.PprLib (ptext)-import Language.Haskell.TH.Syntax (Quasi(..))-import Language.Haskell.TH.TypeGraph.Edges (GraphEdges, simpleEdges)-import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)-import Language.Haskell.TH.TypeGraph.Info (startTypes, TypeInfo, typeVertex', fieldVertex)-import Language.Haskell.TH.TypeGraph.Prelude (HasSet(getSet, modifySet), adjacent', reachable')-import Language.Haskell.TH.TypeGraph.Stack (HasStack(withStack, push), StackElement(StackElement))-import Language.Haskell.TH.TypeGraph.Vertex (TGV, TGVSimple, vsimple, TypeGraphVertex, etype)-import Prelude hiding (any, concat, concatMap, elem, exp, foldr, mapM_, null, or)--instance Ppr Vertex where-    ppr n = ptext ("V" ++ show n)---- | 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.-graphFromMap :: forall key. (Ord key) =>-                GraphEdges key -> (Graph, Vertex -> ((), key, [key]), key -> Maybe Vertex)-graphFromMap mp =-    graphFromEdges triples-    where-      triples :: [((), key, [key])]-      triples = List.map (\ (k, ks) -> ((), k, Foldable.toList ks)) $ Map.toList mp--data TypeGraph-    = TypeGraph-      { _typeInfo :: TypeInfo-      , _edges :: GraphEdges TGV-      , _graph :: (Graph, Vertex -> ((), TGV, [TGV]), TGV -> Maybe Vertex)-      , _gsimple :: (Graph, Vertex -> ((), TGVSimple, [TGVSimple]), TGVSimple -> Maybe Vertex)-      , _stack :: [StackElement]-      }--$(makeLenses ''TypeGraph)--instance Monad m => HasStack (ReaderT TypeGraph m) where-    withStack f = ask >>= f . view stack-    push fld con dec action = local (stack %~ (\s -> StackElement fld con dec : s)) action--allPathStarts :: forall m. (DsMonad m, MonadReader TypeGraph m) => m (Set TGV)-allPathStarts = do-  -- (g, vf, kf) <- graphFromMap <$> view edges-  (g, vf, kf) <- view graph-  kernel <- view typeInfo >>= \ti -> runReaderT (Traversable.mapM expandType (view startTypes ti) >>= Traversable.mapM typeVertex') ti-  let keep = Set.fromList $ concatMap (reachable g) (mapMaybe kf kernel)-      keep' = Set.map (view _2) . Set.map vf $ keep-  return keep'---- | Lenses represent steps in a path, but the start point is a type--- vertex and the endpoint is a field vertex.-allLensKeys ::  (DsMonad m, MonadReader TypeGraph m) => m (Map TGVSimple (Set TGV))-allLensKeys = do-  g <- view graph-  gs <- view gsimple-  allPathStarts >>= return . Map.fromListWith Set.union . List.map (\x -> (view vsimple x, Set.fromList (adjacent' g x))) . Set.toList---- | Paths go between simple types.-allPathKeys :: (DsMonad m, MonadReader TypeGraph m) => m (Map TGVSimple (Set TGVSimple))-allPathKeys = do-  gs <- view gsimple-  allPathStarts >>= return . Map.fromList . List.map (\x -> (x, Set.fromList (reachable' gs x))) . Set.toList . Set.map (view vsimple)--reachableFrom :: forall m. (DsMonad m, MonadReader TypeGraph m) => TGV -> m (Set TGV)-reachableFrom v = do-  -- (g, vf, kf) <- graphFromMap <$> view edges-  (g, vf, kf) <- view graph-  case kf v of-    Nothing -> return Set.empty-    Just v' -> return $ Set.map (\(_, key, _) -> key) . Set.map vf $ Set.fromList $ reachable (transposeG g) v'--reachableFromSimple :: forall m. (DsMonad m, MonadReader TypeGraph m) => TGVSimple -> m (Set TGVSimple)-reachableFromSimple v = do-  -- (g, vf, kf) <- graphFromMap <$> view edges-  (g, vf, kf) <- view gsimple-  case kf v of-    Nothing -> return Set.empty-    Just v' -> return $ Set.map (\(_, key, _) -> key) . Set.map vf $ Set.fromList $ reachable (transposeG g) v'---- | Can we reach the goal type from the start type in this key?-goalReachableFull :: (Functor m, DsMonad m, MonadReader TypeGraph m) => TGV -> TGV -> m Bool-goalReachableFull gkey key0 = isReachable gkey key0 <$> view graph--goalReachableSimple :: (Functor m, DsMonad m, MonadReader TypeGraph m) => TGVSimple -> TGVSimple -> m Bool-goalReachableSimple gkey key0 = isReachable gkey key0 <$> view gsimple--goalReachableSimple' :: (Functor m, DsMonad m, MonadReader TypeGraph m) => TGV -> TGV -> m Bool-goalReachableSimple' gkey key0 = isReachable (view vsimple gkey) (view vsimple key0) <$> view gsimple--isReachable :: TypeGraphVertex key => key -> key -> (Graph, Vertex -> ((), key, [key]), key -> Maybe Vertex) -> Bool-isReachable gkey key0 (g, _vf, kf) = path g (fromJust $ kf key0) (fromJust $ kf gkey)---- | Return the TGV associated with a particular type,--- with no field specified.-typeGraphVertex :: (MonadReader TypeGraph m, DsMonad m) => Type -> m TGV-typeGraphVertex typ = do-        typ' <- expandType typ-        ask >>= runReaderT (typeVertex' typ') . view typeInfo-        -- magnify typeInfo $ vertex Nothing typ'---- | Return the TGV associated with a particular type and field.-typeGraphVertexOfField :: (MonadReader TypeGraph m, DsMonad m) => (Name, Name, Either Int Name) -> Type -> m TGV-typeGraphVertexOfField fld typ = do-        typ' <- expandType typ-        ask >>= runReaderT (fieldVertex fld typ') . view typeInfo-        -- magnify typeInfo $ vertex (Just fld) typ'---- 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-    | 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----- type Edges = GraphEdges TGV---- | Return the set of edges implied by the subtype relationship among--- a set of types.  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.-typeGraphEdges'-    :: forall m. (DsMonad m, MonadReader TypeGraph m, HasSet TGV m) =>-       (TGV -> m (Set TGV))-           -- ^ 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 (GraphEdges TGV)-typeGraphEdges' augment types = do-  execStateT (mapM_ (\typ -> typeGraphVertex typ >>= doNode) types) (mempty :: GraphEdges TGV)-    where-      doNode v = do-        s <- lift $ getSet-        when (not (member v s)) $-             do lift $ modifySet (Set.insert v)-                doNode' v-      doNode' :: TGV -> StateT (GraphEdges TGV) m ()-      doNode' typ = do-        addNode typ-        vs <- lift $ augment typ-        mapM_ (addEdge typ) (Set.toList vs)-        mapM_ doNode (Set.toList vs)--      addNode :: TGV -> StateT (GraphEdges TGV) m ()-      addNode a = modify $ Map.alter (maybe (Just Set.empty) Just) a--      addEdge :: TGV -> TGV -> StateT (GraphEdges TGV) m ()-      addEdge a b = modify $ Map.update (\s -> Just (Set.insert b s)) a---- | Return the set of adjacent vertices according to the default type--- graph - i.e. the one determined only by the type definitions, not--- by any additional hinting function.-adjacent :: forall m. (MonadReader TypeGraph m, DsMonad m) => TGV -> m (Set TGV)-adjacent typ =-    case view (vsimple . etype) typ of-      E (ForallT _ _ typ') -> typeGraphVertex typ' >>= adjacent-      E (AppT c e) ->-          typeGraphVertex c >>= \c' ->-          typeGraphVertex e >>= \e' ->-          return $ Set.fromList [c', e']-      E (ConT name) -> do-        info <- qReify name-        case info of-          TyConI dec -> doDec dec-          _ -> return mempty-      _typ -> return $ {-trace ("Unrecognized type: " ++ pprint' typ)-} mempty-    where-      doDec :: Dec -> m (Set TGV)-      doDec dec@(NewtypeD _ tname _ con _) = doCon tname dec con-      doDec dec@(DataD _ tname _ cns _) = Set.unions <$> Traversable.mapM (doCon tname dec) cns-      doDec (TySynD _tname _tvars typ') = singleton <$> typeGraphVertex typ'-      doDec _ = return mempty--      doCon :: Name -> Dec -> Con -> m (Set TGV)-      doCon tname dec (ForallC _ _ con) = doCon tname dec con-      doCon tname dec (NormalC cname fields) = Set.unions <$> Traversable.mapM (doField tname dec cname) (zip (List.map Left ([1..] :: [Int])) (List.map snd fields))-      doCon tname dec (RecC cname fields) = Set.unions <$> Traversable.mapM (doField tname dec cname) (List.map (\ (fname, _, typ') -> (Right fname, typ')) fields)-      doCon tname dec (InfixC (_, lhs) cname (_, rhs)) = Set.unions <$> Traversable.mapM (doField tname dec cname) [(Left 1, lhs), (Left 2, rhs)]--      doField :: Name -> Dec -> Name -> (Either Int Name, Type) -> m (Set TGV)-      doField tname _dec cname (fld, ftype) = Set.singleton <$> typeGraphVertexOfField (tname, cname, fld) ftype---- FIXME: pass in ti, pass in makeTypeGraphEdges, remove Q, move to TypeGraph.Graph-makeTypeGraph :: MonadReader TypeInfo m => (GraphEdges TGV) -> m TypeGraph-makeTypeGraph es = do-  ti <- ask-  return $ TypeGraph-             { _typeInfo = ti-             , _edges = es-             , _graph = graphFromMap es-             , _gsimple = graphFromMap (simpleEdges es)-             , _stack = []-             }
+ Language/Haskell/TH/TypeGraph/HasState.hs view
@@ -0,0 +1,45 @@+-- | MonadState without the function dependency @m -> s@.+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Language.Haskell.TH.TypeGraph.HasState+    ( HasState(getState, modifyState)+    ) where++import Control.Monad.Reader (ReaderT)+import Control.Monad.RWS (RWST)+import Control.Monad.State (StateT, get, modify)+import Control.Monad.Trans (lift)+import Control.Monad.Writer (WriterT)++-- | This class allows you to access bits of the State by type,+-- without knowing exactly what the overall state type is.  For+-- example:+--+--   typeGraphEdges :: (DsMonad m,+--                      MonadReader TypeGraph m,+--                      HasState (Set TGV) m,+--                      HasState (Map Type (E Type)) m) => ...+--+-- This will work as long as the two HasState instances exist for+-- whatever the actual State type is.  It still can't reach down+-- into nested StateT monads, you may need to use lift for that.++class HasState s m where+    getState :: m s+    modifyState :: (s -> s) -> m ()++instance Monad m => HasState s (StateT s m) where+    getState = get+    modifyState = modify++instance (Monad m, Monoid w) => HasState s (RWST r w s m) where+    getState = get+    modifyState = modify++instance (Monad m, HasState s m) => HasState s (ReaderT r m) where+    getState = lift getState+    modifyState f = lift $ modifyState f++instance (Monad m, Monoid w, HasState s m) => HasState s (WriterT w m) where+    getState = lift getState+    modifyState f = lift $ modifyState f
− Language/Haskell/TH/TypeGraph/Info.hs 
@@ -1,192 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_GHC -Wall #-}-module Language.Haskell.TH.TypeGraph.Info-    ( -- * Type and builders-      TypeInfo, startTypes, fields, infoMap, synonyms, typeSet-    , makeTypeInfo-    -- * Update-    , typeVertex-    , typeVertex'-    , fieldVertex-    -- * Query-    , fieldVertices-    , allVertices-    ) where--#if __GLASGOW_HASKELL__ < 709-import Data.Monoid (mempty)-#endif-import Control.Lens -- (makeLenses, view)-import Control.Monad.Reader (MonadReader)-import Control.Monad.State (execStateT, StateT)-import Control.Monad.Trans as Monad (lift)-import Data.Foldable as Foldable (mapM_)-import Data.List as List (intercalate, map)-import Data.Map as Map (findWithDefault, insert, insertWith, Map, toList)-import Data.Set.Extra as Set (empty, insert, map, mapM_, member, Set, singleton, toList, union)-import Language.Haskell.Exts.Syntax ()-import Language.Haskell.TH-import Language.Haskell.TH.Desugar as DS (DsMonad)-import Language.Haskell.TH.Instances ()-import Language.Haskell.TH.PprLib (ptext)-import Language.Haskell.TH.Syntax as TH (Lift(lift), Quasi(..))-import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)-import Language.Haskell.TH.TypeGraph.Prelude (pprint')-import Language.Haskell.TH.TypeGraph.Shape (Field)-import Language.Haskell.TH.TypeGraph.Vertex (TGV(..), TGVSimple(..), etype)---- | Information collected about the graph implied by the structure of--- one or more 'Type' values.-data TypeInfo-    = TypeInfo-      { _startTypes :: [Type]-      -- ^ The kernel of types from which the others in _typeSet are discovered-      , _typeSet :: Set Type-      -- ^ All the types encountered, including embedded types such as the-      -- 'Maybe' and the 'Int' in @Maybe Int@.-      , _infoMap :: Map Name Info-      -- ^ The Info record of all known named types-      , _expanded :: Map Type (E Type)-      -- ^ Map of the expansion of all encountered types-      , _synonyms :: Map (E Type) (Set Name)-      -- ^ The types with all type synonyms replaced with their expansions.-      , _fields :: Map (E Type) (Set (Name, Name, Either Int Name))-      -- ^ Map from field type to field names-      } deriving (Show, Eq, Ord)--instance Ppr TypeInfo where-    ppr (TypeInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f}) =-        ptext $ intercalate "\n  " ["TypeInfo:", ppt, ppi, ppe, pps, ppf] ++ "\n"-        where-          ppt = intercalate "\n    " ("typeSet:" : concatMap (lines . pprint) (Set.toList t))-          ppi = intercalate "\n    " ("infoMap:" : concatMap (lines . (\ (name, info) -> show name ++ " -> " ++ pprint info)) (Map.toList i))-          ppe = intercalate "\n    " ("expanded:" : concatMap (lines . (\ (typ, (E etyp)) -> pprint typ ++ " -> " ++ pprint etyp)) (Map.toList e))-          pps = intercalate "\n    " ("synonyms:" : concatMap (lines . (\ (typ, ns) -> pprint typ ++ " -> " ++ show ns)) (Map.toList s))-          ppf = intercalate "\n    " ("fields:" : concatMap (lines . (\ (typ, fs) -> pprint typ ++ " -> " ++ show fs)) (Map.toList f))--$(makeLenses ''TypeInfo)--instance Lift TypeInfo where-    lift (TypeInfo {_startTypes = st, _typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f}) =-        [| TypeInfo { _startTypes = $(TH.lift st)-                    , _typeSet = $(TH.lift t)-                    , _infoMap = $(TH.lift i)-                    , _expanded = $(TH.lift e)-                    , _synonyms = $(TH.lift s)-                    , _fields = $(TH.lift f)-                    } |]---- | Collect the graph information for one type and all the types--- reachable from it.-collectTypeInfo :: forall m. DsMonad m => (Type -> m (Set Type)) -> Type -> StateT TypeInfo m ()-collectTypeInfo extraTypes typ0 = do-  doType typ0-    where-      doType :: Type -> StateT TypeInfo m ()-      doType typ = Monad.lift (extraTypes typ) >>= Set.mapM_ doType' . Set.insert typ--      doType' :: Type -> StateT TypeInfo m ()-      doType' typ = do-        (s :: Set Type) <- use typeSet-        case Set.member typ s of-          True -> return ()-          False -> do typeSet %= Set.insert typ-                      etyp{-@(E etyp')-} <- expandType typ-                      expanded %= Map.insert typ etyp-                      -- expanded %= Map.insert etyp' etyp -- A type is its own expansion, but we shouldn't need this-                      doType'' typ--      doType'' :: Type -> StateT TypeInfo m ()-      doType'' (ConT name) = do-        info <- qReify name-        infoMap %= Map.insert name info-        doInfo name info-      doType'' (AppT typ1 typ2) = doType typ1 >> doType typ2-      doType'' ListT = return ()-      doType'' (VarT _) = return ()-      doType'' (TupleT _) = return ()-      doType'' typ = error $ "makeTypeInfo: " ++ pprint' typ--      doInfo :: Name -> Info -> StateT TypeInfo m ()-      doInfo _tname (TyConI dec) = doDec dec-      doInfo _tname (PrimTyConI _ _ _) = return ()-      doInfo _tname (FamilyI _ _) = return () -- Not sure what to do here-      doInfo _ info = error $ "makeTypeInfo: " ++ show info--      doDec :: Dec -> StateT TypeInfo m ()-      doDec (TySynD tname _ typ) = do-        etyp <- expandType (ConT tname)-        synonyms %= Map.insertWith union etyp (singleton tname)-        doType typ-      doDec (NewtypeD _ tname _ constr _) = doCon tname constr-      doDec (DataD _ tname _ constrs _) = Foldable.mapM_ (doCon tname) constrs-      doDec dec = error $ "makeTypeInfo: " ++ pprint' dec--      doCon :: Name -> Con -> StateT TypeInfo m ()-      doCon tname (ForallC _ _ con) = doCon tname con-      doCon tname (NormalC cname flds) = Foldable.mapM_ doField (zip (List.map (\n -> (tname, cname, Left n)) ([1..] :: [Int])) (List.map snd flds))-      doCon tname (RecC cname flds) = Foldable.mapM_ doField (List.map (\ (fname, _, ftype) -> ((tname, cname, Right fname), ftype)) flds)-      doCon tname (InfixC (_, lhs) cname (_, rhs)) = Foldable.mapM_ doField [((tname, cname, Left 1), lhs), ((tname, cname, Left 2), rhs)]--      doField :: ((Name, Name, Either Int Name), Type) -> StateT TypeInfo m ()-      doField (fld, ftyp) = do-        etyp <- expandType ftyp-        fields %= Map.insertWith union etyp (singleton fld)-        doType ftyp---- | Build a TypeInfo value by scanning the supplied types-makeTypeInfo :: forall m. DsMonad m => (Type -> m (Set Type)) -> [Type] -> m TypeInfo-makeTypeInfo extraTypes types =-    execStateT-      (Foldable.mapM_ (collectTypeInfo extraTypes) types)-      (TypeInfo { _startTypes = types-                , _typeSet = mempty-                , _infoMap = mempty-                , _expanded = mempty-                , _synonyms = mempty-                , _fields = mempty})--allVertices :: (Functor m, DsMonad m, MonadReader TypeInfo m) => Maybe Field -> E Type -> m (Set TGV)-allVertices (Just fld) etyp = singleton <$> fieldVertex fld etyp-allVertices Nothing etyp = do-  v <- typeVertex etyp-  vs <- fieldVertices v-  return $ Set.insert (TGV {_vsimple = v, _field = Nothing}) vs---- | Find the vertices that involve a particular type - if the field--- is specified it return s singleton, otherwise it returns a set--- containing a vertex one for the type on its own, and one for each--- field containing that type.-fieldVertices :: MonadReader TypeInfo m => TGVSimple -> m (Set TGV)-fieldVertices v = do-  fm <- view fields-  let fs = Map.findWithDefault Set.empty (view etype v) fm-  return $ Set.map (\fld' -> TGV {_vsimple = v, _field = Just fld'}) fs---- | Build a vertex from the given 'Type' and optional 'Field'.--- vertex :: forall m. (DsMonad m, MonadReader TypeInfo m) => Maybe Field -> E Type -> m TypeGraphVertex--- vertex fld etyp = maybe (typeVertex etyp) (fieldVertex etyp) fld---- | Build a non-field vertex-typeVertex :: MonadReader TypeInfo m => E Type -> m TGVSimple-typeVertex etyp = do-  sm <- view synonyms-  return $ TGVSimple {_syns = Map.findWithDefault Set.empty etyp sm, _etype = etyp}--typeVertex' :: MonadReader TypeInfo m => E Type -> m TGV-typeVertex' etyp = do-  v <- typeVertex etyp-  return $ TGV {_vsimple = v, _field = Nothing}---- | Build a vertex associated with a field-fieldVertex :: MonadReader TypeInfo m => Field -> E Type -> m TGV-fieldVertex fld' etyp = typeVertex etyp >>= \v -> return $ TGV {_vsimple = v, _field = Just fld'}
Language/Haskell/TH/TypeGraph/Prelude.hs view
@@ -11,7 +11,6 @@     , constructorName     , declarationName     , declarationType-    , HasSet(getSet, modifySet)     , unReify     , unReifyName     , adjacent'@@ -96,17 +95,11 @@ declarationName (TySynInstD name _) = Just name declarationName (ClosedTypeFamilyD name _ _ _) = Just name declarationName (RoleAnnotD name _) = Just name-#if __GLASGOW_HASKELL__ >= 709 declarationName (StandaloneDerivD _ _) = Nothing declarationName (DefaultSigD name _) = Just name-#endif  declarationType :: Dec -> Maybe Type declarationType = fmap ConT . declarationName--class HasSet a m where-    getSet :: m (Set a)-    modifySet :: (Set a -> Set a) -> m ()  instance Lift a => Lift (Set a) where     lift s = [|Set.fromList $(lift (Set.toList s))|]
Language/Haskell/TH/TypeGraph/Shape.hs view
@@ -1,4 +1,4 @@--- | A fold on the shape of a record.+-- | A fold on the shape of the constructors of a DataD or NewtypeD record. {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-}
Language/Haskell/TH/TypeGraph/Stack.hs view
@@ -43,13 +43,15 @@ import Debug.Trace (trace) import Language.Haskell.Exts.Syntax () import Language.Haskell.TH+import Language.Haskell.TH.Desugar (DsMonad) import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding (lift) import Language.Haskell.TH.TypeGraph.Edges (GraphEdges, simpleEdges, typeGraphEdges)-import Language.Haskell.TH.TypeGraph.Expand (E(E))-import Language.Haskell.TH.TypeGraph.Info (makeTypeInfo)+import Language.Haskell.TH.TypeGraph.Expand (E(E), ExpandMap)+import Language.Haskell.TH.TypeGraph.HasState (HasState) import Language.Haskell.TH.TypeGraph.Prelude (constructorName) import Language.Haskell.TH.TypeGraph.Shape (FieldType(..), fName, fType, constructorFieldTypes)+import Language.Haskell.TH.TypeGraph.TypeInfo (makeTypeInfo) import Language.Haskell.TH.TypeGraph.Vertex (etype, TGV) import Prelude hiding ((.)) @@ -181,7 +183,7 @@ -- The only reason for this function is backwards compatibility, the -- fields should be changed so they begin with _ and the regular -- makeLenses should be used.-makeLenses' :: (Type -> Q (Set Type)) -> [Name] -> Q [Dec]+makeLenses' :: forall m. (DsMonad m, HasState ExpandMap m) => (Type -> m (Set Type)) -> [Name] -> m [Dec] makeLenses' extraTypes typeNames =     execWriterT $ execStackT $ makeTypeInfo (lift . lift . extraTypes) st >>= runReaderT typeGraphEdges >>= \ (g :: GraphEdges TGV) -> (mapM doType . map (view etype) . Map.keys . simpleEdges $ g)     where@@ -195,7 +197,7 @@       doCons dec typeName cons = mapM_ (\ con -> mapM_ (foldField (doField typeName) dec con) (constructorFieldTypes con)) cons        -- (mkName $ nameBase $ tName dec) dec lensNamer) >>= tell-      doField :: Name -> FieldType -> StackT (WriterT [Dec] Q) ()+      doField :: Name -> FieldType -> StackT (WriterT [Dec] m) ()       doField typeName (Named (fieldName, _, fieldType)) =           doFieldType typeName fieldName fieldType       doField _ _ = return ()
+ Language/Haskell/TH/TypeGraph/TypeGraph.hs view
@@ -0,0 +1,264 @@+-- | Abstract operations on Maps containing graph edges.++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-}++module Language.Haskell.TH.TypeGraph.TypeGraph+    ( TypeGraph, typeInfo, edges, graph, gsimple, stack+    , graphFromMap++    , allLensKeys+    , allPathKeys+    , allPathStarts+    , reachableFrom+    , reachableFromSimple+    , goalReachableFull+    , goalReachableSimple+    , goalReachableSimple'++    , makeTypeGraph+    , VertexStatus(..)+    , typeGraphEdges'+    , adjacent+    , typeGraphVertex+    , typeGraphVertexOfField+    ) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+import Data.Monoid (mempty)+#else+import Control.Applicative+#endif+import Control.Lens -- (makeLenses, over, view)+import Control.Monad (when)+import Control.Monad.Reader (ask, local, MonadReader, ReaderT, runReaderT)+import Control.Monad.State (execStateT, modify, StateT)+import Control.Monad.Trans (lift)+import Data.Default (Default(def))+import Data.Foldable as Foldable+import Data.Graph hiding (edges)+import Data.List as List (map)+import Data.Map as Map (alter, fromList, fromListWith, Map, update)+import qualified Data.Map as Map (toList)+import Data.Maybe (fromJust, mapMaybe)+import Data.Set.Extra as Set (empty, fromList, insert, map, member, Set, singleton, toList, union, unions)+import Data.Traversable as Traversable+import Language.Haskell.Exts.Syntax ()+import Language.Haskell.TH+import Language.Haskell.TH.Desugar (DsMonad)+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.PprLib (ptext)+import Language.Haskell.TH.Syntax (Quasi(..))+import Language.Haskell.TH.TypeGraph.Edges (GraphEdges, simpleEdges)+import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)+import Language.Haskell.TH.TypeGraph.HasState (HasState(getState, modifyState))+import Language.Haskell.TH.TypeGraph.Prelude (adjacent', reachable')+import Language.Haskell.TH.TypeGraph.TypeInfo (startTypes, TypeInfo, typeVertex', fieldVertex)+import Language.Haskell.TH.TypeGraph.Stack (HasStack(withStack, push), StackElement(StackElement))+import Language.Haskell.TH.TypeGraph.Vertex (TGV, TGVSimple, vsimple, TypeGraphVertex, etype)+import Prelude hiding (any, concat, concatMap, elem, exp, foldr, mapM_, null, or)++instance Ppr Vertex where+    ppr n = ptext ("V" ++ show n)++-- | 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.+graphFromMap :: forall key. (Ord key) =>+                GraphEdges key -> (Graph, Vertex -> ((), key, [key]), key -> Maybe Vertex)+graphFromMap mp =+    graphFromEdges triples+    where+      triples :: [((), key, [key])]+      triples = List.map (\ (k, ks) -> ((), k, Foldable.toList ks)) $ Map.toList mp++data TypeGraph+    = TypeGraph+      { _typeInfo :: TypeInfo+      , _edges :: GraphEdges TGV+      , _graph :: (Graph, Vertex -> ((), TGV, [TGV]), TGV -> Maybe Vertex)+      , _gsimple :: (Graph, Vertex -> ((), TGVSimple, [TGVSimple]), TGVSimple -> Maybe Vertex)+      , _stack :: [StackElement]+      }++$(makeLenses ''TypeGraph)++instance Monad m => HasStack (ReaderT TypeGraph m) where+    withStack f = ask >>= f . view stack+    push fld con dec action = local (stack %~ (\s -> StackElement fld con dec : s)) action++allPathStarts :: forall m. (DsMonad m, HasState (Map Type (E Type)) m, MonadReader TypeGraph m) => m (Set TGV)+allPathStarts = do+  -- (g, vf, kf) <- graphFromMap <$> view edges+  (g, vf, kf) <- view graph+  kernel <- view typeInfo >>= \ti -> runReaderT (Traversable.mapM expandType (view startTypes ti) >>= Traversable.mapM typeVertex') ti+  let keep = Set.fromList $ concatMap (reachable g) (mapMaybe kf kernel)+      keep' = Set.map (view _2) . Set.map vf $ keep+  return keep'++-- | Lenses represent steps in a path, but the start point is a type+-- vertex and the endpoint is a field vertex.+allLensKeys ::  (DsMonad m, HasState (Map Type (E Type)) m, MonadReader TypeGraph m) => m (Map TGVSimple (Set TGV))+allLensKeys = do+  g <- view graph+  gs <- view gsimple+  allPathStarts >>= return . Map.fromListWith Set.union . List.map (\x -> (view vsimple x, Set.fromList (adjacent' g x))) . Set.toList++-- | Paths go between simple types.+allPathKeys :: (DsMonad m, HasState (Map Type (E Type)) m, MonadReader TypeGraph m) => m (Map TGVSimple (Set TGVSimple))+allPathKeys = do+  gs <- view gsimple+  allPathStarts >>= return . Map.fromList . List.map (\x -> (x, Set.fromList (reachable' gs x))) . Set.toList . Set.map (view vsimple)++reachableFrom :: forall m. (DsMonad m, MonadReader TypeGraph m) => TGV -> m (Set TGV)+reachableFrom v = do+  -- (g, vf, kf) <- graphFromMap <$> view edges+  (g, vf, kf) <- view graph+  case kf v of+    Nothing -> return Set.empty+    Just v' -> return $ Set.map (\(_, key, _) -> key) . Set.map vf $ Set.fromList $ reachable (transposeG g) v'++reachableFromSimple :: forall m. (DsMonad m, MonadReader TypeGraph m) => TGVSimple -> m (Set TGVSimple)+reachableFromSimple v = do+  -- (g, vf, kf) <- graphFromMap <$> view edges+  (g, vf, kf) <- view gsimple+  case kf v of+    Nothing -> return Set.empty+    Just v' -> return $ Set.map (\(_, key, _) -> key) . Set.map vf $ Set.fromList $ reachable (transposeG g) v'++-- | Can we reach the goal type from the start type in this key?+goalReachableFull :: (Functor m, DsMonad m, MonadReader TypeGraph m) => TGV -> TGV -> m Bool+goalReachableFull gkey key0 = isReachable gkey key0 <$> view graph++goalReachableSimple :: (Functor m, DsMonad m, MonadReader TypeGraph m) => TGVSimple -> TGVSimple -> m Bool+goalReachableSimple gkey key0 = isReachable gkey key0 <$> view gsimple++goalReachableSimple' :: (Functor m, DsMonad m, MonadReader TypeGraph m) => TGV -> TGV -> m Bool+goalReachableSimple' gkey key0 = isReachable (view vsimple gkey) (view vsimple key0) <$> view gsimple++isReachable :: TypeGraphVertex key => key -> key -> (Graph, Vertex -> ((), key, [key]), key -> Maybe Vertex) -> Bool+isReachable gkey key0 (g, _vf, kf) = path g (fromJust $ kf key0) (fromJust $ kf gkey)++-- | Return the TGV associated with a particular type,+-- with no field specified.+typeGraphVertex :: (MonadReader TypeGraph m, HasState (Map Type (E Type)) m, DsMonad m) => Type -> m TGV+typeGraphVertex typ = do+        typ' <- expandType typ+        ask >>= runReaderT (typeVertex' typ') . view typeInfo+        -- magnify typeInfo $ vertex Nothing typ'++-- | Return the TGV associated with a particular type and field.+typeGraphVertexOfField :: (MonadReader TypeGraph m, HasState (Map Type (E Type)) m, DsMonad m) => (Name, Name, Either Int Name) -> Type -> m TGV+typeGraphVertexOfField fld typ = do+        typ' <- expandType typ+        ask >>= runReaderT (fieldVertex fld typ') . view typeInfo+        -- magnify typeInfo $ vertex (Just fld) typ'++-- 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+    | 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++--- type Edges = GraphEdges TGV++-- | Return the set of edges implied by the subtype relationship among+-- a set of types.  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.+typeGraphEdges'+    :: forall m. (DsMonad m, MonadReader TypeGraph m, HasState (Set TGV) m, HasState (Map Type (E Type)) m) =>+       (TGV -> m (Set TGV))+           -- ^ 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 (GraphEdges TGV)+typeGraphEdges' augment types = do+  execStateT (mapM_ (\typ -> lift (typeGraphVertex typ) >>= doNode) types) (mempty :: GraphEdges TGV)+    where+      doNode v = do+        (s :: Set TGV) <- lift $ getState+        when (not (member v s)) $+             do lift $ modifyState (Set.insert v)+                doNode' v+      doNode' :: TGV -> StateT (GraphEdges TGV) m ()+      doNode' typ = do+        addNode typ+        vs <- lift $ augment typ+        mapM_ (addEdge typ) (Set.toList vs)+        mapM_ doNode (Set.toList vs)++      addNode :: TGV -> StateT (GraphEdges TGV) m ()+      addNode a = modify $ Map.alter (maybe (Just Set.empty) Just) a++      addEdge :: TGV -> TGV -> StateT (GraphEdges TGV) m ()+      addEdge a b = modify $ Map.update (\s -> Just (Set.insert b s)) a++-- | Return the set of adjacent vertices according to the default type+-- graph - i.e. the one determined only by the type definitions, not+-- by any additional hinting function.+adjacent :: forall m. (MonadReader TypeGraph m, DsMonad m, HasState (Map Type (E Type)) m) => TGV -> m (Set TGV)+adjacent typ =+    case view (vsimple . etype) typ of+      E (ForallT _ _ typ') -> typeGraphVertex typ' >>= adjacent+      E (AppT c e) ->+          typeGraphVertex c >>= \c' ->+          typeGraphVertex e >>= \e' ->+          return $ Set.fromList [c', e']+      E (ConT name) -> do+        info <- qReify name+        case info of+          TyConI dec -> doDec dec+          _ -> return mempty+      _typ -> return $ {-trace ("Unrecognized type: " ++ pprint' typ)-} mempty+    where+      doDec :: Dec -> m (Set TGV)+      doDec dec@(NewtypeD _ tname _ con _) = doCon tname dec con+      doDec dec@(DataD _ tname _ cns _) = Set.unions <$> Traversable.mapM (doCon tname dec) cns+      doDec (TySynD _tname _tvars typ') = singleton <$> typeGraphVertex typ'+      doDec _ = return mempty++      doCon :: Name -> Dec -> Con -> m (Set TGV)+      doCon tname dec (ForallC _ _ con) = doCon tname dec con+      doCon tname dec (NormalC cname fields) = Set.unions <$> Traversable.mapM (doField tname dec cname) (zip (List.map Left ([1..] :: [Int])) (List.map snd fields))+      doCon tname dec (RecC cname fields) = Set.unions <$> Traversable.mapM (doField tname dec cname) (List.map (\ (fname, _, typ') -> (Right fname, typ')) fields)+      doCon tname dec (InfixC (_, lhs) cname (_, rhs)) = Set.unions <$> Traversable.mapM (doField tname dec cname) [(Left 1, lhs), (Left 2, rhs)]++      doField :: Name -> Dec -> Name -> (Either Int Name, Type) -> m (Set TGV)+      doField tname _dec cname (fld, ftype) = Set.singleton <$> typeGraphVertexOfField (tname, cname, fld) ftype++-- FIXME: pass in ti, pass in makeTypeGraphEdges, remove Q, move to TypeGraph.Graph+makeTypeGraph :: MonadReader TypeInfo m => (GraphEdges TGV) -> m TypeGraph+makeTypeGraph es = do+  ti <- ask+  return $ TypeGraph+             { _typeInfo = ti+             , _edges = es+             , _graph = graphFromMap es+             , _gsimple = graphFromMap (simpleEdges es)+             , _stack = []+             }
+ Language/Haskell/TH/TypeGraph/TypeInfo.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall #-}+module Language.Haskell.TH.TypeGraph.TypeInfo+    ( -- * Type and builders+      TypeInfo, startTypes, fields, infoMap, synonyms, typeSet+    , makeTypeInfo+    -- * Update+    , typeVertex+    , typeVertex'+    , fieldVertex+    -- * Query+    , fieldVertices+    , allVertices+    ) where++#if __GLASGOW_HASKELL__ < 709+import Data.Monoid (mempty)+#endif+import Control.Lens -- (makeLenses, view)+import Control.Monad.Reader (MonadReader)+import Control.Monad.State (execStateT, StateT)+import Control.Monad.Trans as Monad (lift)+import Data.Foldable as Foldable (mapM_)+import Data.List as List (intercalate, map)+import Data.Map as Map (findWithDefault, insert, insertWith, Map, toList)+import Data.Set.Extra as Set (empty, insert, map, mapM_, member, Set, singleton, toList, union)+import Language.Haskell.Exts.Syntax ()+import Language.Haskell.TH+import Language.Haskell.TH.Desugar as DS (DsMonad)+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.PprLib (ptext)+import Language.Haskell.TH.Syntax as TH (Lift(lift), Quasi(..))+import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)+import Language.Haskell.TH.TypeGraph.HasState (HasState(getState, modifyState))+import Language.Haskell.TH.TypeGraph.Prelude (pprint')+import Language.Haskell.TH.TypeGraph.Shape (Field)+import Language.Haskell.TH.TypeGraph.Vertex (TGV(..), TGVSimple(..), etype)++-- | Information collected about the graph implied by the structure of+-- one or more 'Type' values.+data TypeInfo+    = TypeInfo+      { _startTypes :: [Type]+      -- ^ The kernel of types from which the others in _typeSet are discovered+      , _typeSet :: Set Type+      -- ^ All the types encountered, including embedded types such as the+      -- 'Maybe' and the 'Int' in @Maybe Int@.+      , _infoMap :: Map Name Info+      -- ^ The Info record of all known named types+      , _expanded :: Map Type (E Type)+      -- ^ Map of the expansion of all encountered types+      , _synonyms :: Map (E Type) (Set Name)+      -- ^ The types with all type synonyms replaced with their expansions.+      , _fields :: Map (E Type) (Set (Name, Name, Either Int Name))+      -- ^ Map from field type to field names+      } deriving (Show, Eq, Ord)++instance Ppr TypeInfo where+    ppr (TypeInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f}) =+        ptext $ intercalate "\n  " ["TypeInfo:", ppt, ppi, ppe, pps, ppf] ++ "\n"+        where+          ppt = intercalate "\n    " ("typeSet:" : concatMap (lines . pprint) (Set.toList t))+          ppi = intercalate "\n    " ("infoMap:" : concatMap (lines . (\ (name, info) -> show name ++ " -> " ++ pprint info)) (Map.toList i))+          ppe = intercalate "\n    " ("expanded:" : concatMap (lines . (\ (typ, (E etyp)) -> pprint typ ++ " -> " ++ pprint etyp)) (Map.toList e))+          pps = intercalate "\n    " ("synonyms:" : concatMap (lines . (\ (typ, ns) -> pprint typ ++ " -> " ++ show ns)) (Map.toList s))+          ppf = intercalate "\n    " ("fields:" : concatMap (lines . (\ (typ, fs) -> pprint typ ++ " -> " ++ show fs)) (Map.toList f))++$(makeLenses ''TypeInfo)++instance Monad m => HasState (Map Type (E Type)) (StateT TypeInfo m) where+    getState = use expanded+    modifyState f = expanded %= f++instance Lift TypeInfo where+    lift (TypeInfo {_startTypes = st, _typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f}) =+        [| TypeInfo { _startTypes = $(TH.lift st)+                    , _typeSet = $(TH.lift t)+                    , _infoMap = $(TH.lift i)+                    , _expanded = $(TH.lift e)+                    , _synonyms = $(TH.lift s)+                    , _fields = $(TH.lift f)+                    } |]++-- | Collect the graph information for one type and all the types+-- reachable from it.  The extraTypes function parameter allows extra+-- edges to be added to the graph other than those implied by the Type+-- structure.+collectTypeInfo :: forall m. DsMonad m => (Type -> m (Set Type)) -> Type -> StateT TypeInfo m ()+collectTypeInfo extraTypes typ0 = do+  doType typ0+    where+      doType :: Type -> StateT TypeInfo m ()+      doType typ = Monad.lift (extraTypes typ) >>= Set.mapM_ doType' . Set.insert typ++      doType' :: Type -> StateT TypeInfo m ()+      doType' typ = do+        (s :: Set Type) <- use typeSet+        case Set.member typ s of+          True -> return ()+          False -> do typeSet %= Set.insert typ+                      etyp{-@(E etyp')-} <- expandType typ+                      expanded %= Map.insert typ etyp+                      -- expanded %= Map.insert etyp' etyp -- A type is its own expansion, but we shouldn't need this+                      doType'' typ++      doType'' :: Type -> StateT TypeInfo m ()+      doType'' (ConT name) = do+        info <- qReify name+        infoMap %= Map.insert name info+        doInfo name info+      doType'' (AppT typ1 typ2) = doType typ1 >> doType typ2+      doType'' ListT = return ()+      doType'' (VarT _) = return ()+      doType'' (TupleT _) = return ()+      doType'' typ = error $ "makeTypeInfo: " ++ pprint' typ++      doInfo :: Name -> Info -> StateT TypeInfo m ()+      doInfo _tname (TyConI dec) = doDec dec+      doInfo _tname (PrimTyConI _ _ _) = return ()+      doInfo _tname (FamilyI _ _) = return () -- Not sure what to do here+      doInfo _ info = error $ "makeTypeInfo: " ++ show info++      doDec :: Dec -> StateT TypeInfo m ()+      doDec (TySynD tname _ typ) = do+        etyp <- expandType (ConT tname)+        synonyms %= Map.insertWith union etyp (singleton tname)+        doType typ+      doDec (NewtypeD _ tname _ constr _) = doCon tname constr+      doDec (DataD _ tname _ constrs _) = Foldable.mapM_ (doCon tname) constrs+      doDec dec = error $ "makeTypeInfo: " ++ pprint' dec++      doCon :: Name -> Con -> StateT TypeInfo m ()+      doCon tname (ForallC _ _ con) = doCon tname con+      doCon tname (NormalC cname flds) = Foldable.mapM_ doField (zip (List.map (\n -> (tname, cname, Left n)) ([1..] :: [Int])) (List.map snd flds))+      doCon tname (RecC cname flds) = Foldable.mapM_ doField (List.map (\ (fname, _, ftype) -> ((tname, cname, Right fname), ftype)) flds)+      doCon tname (InfixC (_, lhs) cname (_, rhs)) = Foldable.mapM_ doField [((tname, cname, Left 1), lhs), ((tname, cname, Left 2), rhs)]++      doField :: ((Name, Name, Either Int Name), Type) -> StateT TypeInfo m ()+      doField (fld, ftyp) = do+        etyp <- expandType ftyp+        fields %= Map.insertWith union etyp (singleton fld)+        doType ftyp++-- | Build a TypeInfo value by scanning the supplied types+makeTypeInfo :: forall m. DsMonad m => (Type -> m (Set Type)) -> [Type] -> m TypeInfo+makeTypeInfo extraTypes types =+    execStateT+      (Foldable.mapM_ (collectTypeInfo extraTypes) types)+      (TypeInfo { _startTypes = types+                , _typeSet = mempty+                , _infoMap = mempty+                , _expanded = mempty+                , _synonyms = mempty+                , _fields = mempty})++allVertices :: (Functor m, DsMonad m, MonadReader TypeInfo m) => Maybe Field -> E Type -> m (Set TGV)+allVertices (Just fld) etyp = singleton <$> fieldVertex fld etyp+allVertices Nothing etyp = do+  v <- typeVertex etyp+  vs <- fieldVertices v+  return $ Set.insert (TGV {_vsimple = v, _field = Nothing}) vs++-- | Find the vertices that involve a particular type - if the field+-- is specified it return s singleton, otherwise it returns a set+-- containing a vertex one for the type on its own, and one for each+-- field containing that type.+fieldVertices :: MonadReader TypeInfo m => TGVSimple -> m (Set TGV)+fieldVertices v = do+  fm <- view fields+  let fs = Map.findWithDefault Set.empty (view etype v) fm+  return $ Set.map (\fld' -> TGV {_vsimple = v, _field = Just fld'}) fs++-- | Build a vertex from the given 'Type' and optional 'Field'.+-- vertex :: forall m. (DsMonad m, MonadReader TypeInfo m) => Maybe Field -> E Type -> m TypeGraphVertex+-- vertex fld etyp = maybe (typeVertex etyp) (fieldVertex etyp) fld++-- | Build a non-field vertex+typeVertex :: MonadReader TypeInfo m => E Type -> m TGVSimple+typeVertex etyp = do+  sm <- view synonyms+  return $ TGVSimple {_syns = Map.findWithDefault Set.empty etyp sm, _etype = etyp}++typeVertex' :: MonadReader TypeInfo m => E Type -> m TGV+typeVertex' etyp = do+  v <- typeVertex etyp+  return $ TGV {_vsimple = v, _field = Nothing}++-- | Build a vertex associated with a field+fieldVertex :: MonadReader TypeInfo m => Field -> E Type -> m TGV+fieldVertex fld' etyp = typeVertex etyp >>= \v -> return $ TGV {_vsimple = v, _field = Just fld'}
− Language/Haskell/TH/TypeGraph/Unsafe.hs 
@@ -1,24 +0,0 @@--- | Degenerate instances of Expanded that must be explicitly imported--- if you want to use them.  They are fine for simple uses of--- expandType, but not if you are trying to use the return value of--- expandType as a Map key.--{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Language.Haskell.TH.TypeGraph.Unsafe () where--import Language.Haskell.TH.TypeGraph.Expand (Expanded(markExpanded, runExpanded'))-import Language.Haskell.TH (Type)--#if __GLASGOW_HASKELL__ < 709-import Language.Haskell.TH (Pred)--instance Expanded Pred Pred where-    markExpanded = id-    runExpanded' = id-#endif--instance Expanded Type Type where-    markExpanded = id-    runExpanded' = id
Language/Haskell/TH/TypeGraph/Vertex.hs view
@@ -15,7 +15,7 @@ import Language.Haskell.TH.Instances () import Language.Haskell.TH.PprLib (hcat, ptext) import Language.Haskell.TH.Syntax (Lift(lift))-import Language.Haskell.TH.TypeGraph.Expand (E(E), runExpanded)+import Language.Haskell.TH.TypeGraph.Expand (E(E, unE)) import Language.Haskell.TH.TypeGraph.Prelude (unReify, unReifyName) import Language.Haskell.TH.TypeGraph.Shape (Field) @@ -40,7 +40,7 @@  instance Ppr TGVSimple where     ppr (TGVSimple {_syns = ns, _etype = typ}) =-        hcat (ppr (unReify (runExpanded typ)) :+        hcat (ppr (unReify (unE typ)) :               case (Set.toList ns) of                  [] -> []                  _ ->   [ptext " ("] ++@@ -50,7 +50,7 @@  instance Ppr TGV where     ppr (TGV {_field = fld, _vsimple = TGVSimple {_syns = ns, _etype = typ}}) =-        hcat (ppr (unReify (runExpanded typ)) :+        hcat (ppr (unReify (unE typ)) :               case (fld, Set.toList ns) of                  (Nothing, []) -> []                  _ ->   [ptext " ("] ++
test/Common.hs view
@@ -13,11 +13,12 @@ import Language.Haskell.TH import Language.Haskell.TH.Desugar (DsMonad) import Language.Haskell.TH.TypeGraph.Edges (GraphEdges)-import Language.Haskell.TH.TypeGraph.Expand (E, markExpanded, runExpanded)-import Language.Haskell.TH.TypeGraph.Info (TypeInfo)+import Language.Haskell.TH.TypeGraph.Expand (E(unE)) import Language.Haskell.TH.TypeGraph.Edges (typeGraphEdges)+import Language.Haskell.TH.TypeGraph.HasState (HasState) import Language.Haskell.TH.TypeGraph.Prelude (pprint') import Language.Haskell.TH.TypeGraph.Shape (Field)+import Language.Haskell.TH.TypeGraph.TypeInfo (TypeInfo) import Language.Haskell.TH.TypeGraph.Vertex (etype, syns, TGV, TGVSimple, TypeGraphVertex, vsimple)  import Language.Haskell.TH.Syntax (Lift(lift))@@ -44,23 +45,23 @@ pprintDec = pprint' . unReify  pprintType :: E Type -> String-pprintType = pprint' . unReify . runExpanded+pprintType = pprint' . unReify . unE  pprintVertex :: Ppr v => v -> String pprintVertex = pprint'  pprintPred :: E Pred -> String-pprintPred = pprint' . unReify . runExpanded+pprintPred = pprint' . unReify . unE  edgesToStrings :: (TypeGraphVertex v, Ppr v) => GraphEdges v -> [(String, [String])] edgesToStrings mp = List.map (\ (t, s) -> (pprintVertex t, map pprintVertex (Set.toList s))) (Map.toList mp) -typeGraphEdges' :: forall m. (DsMonad m, MonadReader TypeInfo m) => m (GraphEdges TGV)+typeGraphEdges' :: forall m. (DsMonad m, MonadReader TypeInfo m, HasState (Map Type (E Type)) m) => m (GraphEdges TGV) typeGraphEdges' = typeGraphEdges  -- | Return a mapping from vertex to all the known type synonyms for -- the type in that vertex.-typeSynonymMap :: forall m. (DsMonad m, MonadReader TypeInfo m) =>+typeSynonymMap :: forall m. (DsMonad m, MonadReader TypeInfo m, HasState (Map Type (E Type)) m) =>                   m (Map TGV (Set Name)) typeSynonymMap =      (Map.filter (not . Set.null) .@@ -69,7 +70,7 @@       Map.keys) <$> (typeGraphEdges :: m (GraphEdges TGV))  -- | Like 'typeSynonymMap', but with all field information removed.-typeSynonymMapSimple :: forall m. (DsMonad m, MonadReader TypeInfo m) =>+typeSynonymMapSimple :: forall m. (DsMonad m, MonadReader TypeInfo m, HasState (Map Type (E Type)) m) =>                         m (Map (E Type) (Set Name)) typeSynonymMapSimple =     simplify <$> typeSynonymMap
test/TypeGraph.hs view
@@ -9,14 +9,16 @@ #endif import Control.Lens import Control.Monad.Reader (runReaderT)+import Control.Monad.State (evalStateT) import Data.List as List (map)-import Data.Map as Map (Map, fromList, keys)+import Data.Map as Map (Map, empty, fromList, keys) import Data.Set as Set (fromList, singleton) import Language.Haskell.TH+import Language.Haskell.TH.TypeGraph.Arity (typeArity) import Language.Haskell.TH.TypeGraph.Edges (dissolveM, simpleEdges)-import Language.Haskell.TH.TypeGraph.Expand (expandType, runExpanded, E(E))-import Language.Haskell.TH.TypeGraph.Free (freeTypeVars, typeArity)-import Language.Haskell.TH.TypeGraph.Info (makeTypeInfo, synonyms, typeVertex')+import Language.Haskell.TH.TypeGraph.Expand (expandType, E(E, unE))+import Language.Haskell.TH.TypeGraph.Free (freeTypeVars)+import Language.Haskell.TH.TypeGraph.TypeInfo (makeTypeInfo, synonyms, typeVertex') import Language.Haskell.TH.TypeGraph.Vertex (TGV(..), TGVSimple(..), etype) import Language.Haskell.TH.Desugar (withLocalDeclarations) import Language.Haskell.TH.Instances ()@@ -34,37 +36,41 @@      $([t|String|] >>= \string -> makeTypeInfo (const $ return mempty) [string] >>= lift . view synonyms) `shouldBe` (Map.fromList [(E (AppT ListT (ConT ''Char)), Set.singleton ''String)])    it "records a type synonym 2" $ do-     $([t|String|] >>= \string -> makeTypeInfo (const $ return mempty) [string] >>= runReaderT (expandType string >>= typeVertex') >>= lift) `shouldBe` (TGV {_field = Nothing, _vsimple = TGVSimple {_syns = singleton ''String, _etype = E (AppT ListT (ConT ''Char))}})+     $([t|String|] >>= \string ->+       flip evalStateT (Map.empty :: Map Type (E Type))+                (makeTypeInfo (const $ return mempty) [string] >>=+                 runReaderT (expandType string >>= typeVertex')) >>= lift)+          `shouldBe` (TGV {_field = Nothing, _vsimple = TGVSimple {_syns = singleton ''String, _etype = E (AppT ListT (ConT ''Char))}})    it "can build the TypeInfoGraph for Type" $ do     $(runQ [t|Type|] >>= \typ -> makeTypeInfo (const $ return mempty) [typ] >>= lift . pprint) `shouldBe` typeInfoOfType    it "can find the edges of the (simplified) subtype graph of Type (typeEdges)" $ do-     setDifferences (Set.fromList $(withLocalDeclarations [] $-                                runQ [t|Type|] >>= \typ ->-                                makeTypeInfo (const $ return mempty) [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=-                                runQ . lift . edgesToStrings)) simpleTypeEdges+     setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: Map Type (E Type)) $+                                      runQ [t|Type|] >>= \typ ->+                                      makeTypeInfo (const $ return mempty) [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=+                                      runQ . lift . edgesToStrings)) simpleTypeEdges         `shouldBe` noDifferences    it "can find the edges of the (unsimplified) subtype graph of Type (typeEdges)" $ do-     setDifferences (Set.fromList $(withLocalDeclarations [] $+     setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: Map Type (E Type)) $                                 runQ [t|Type|] >>= \typ ->                                 makeTypeInfo (const $ return mempty) [typ] >>= runReaderT typeGraphEdges' >>=                                 runQ . lift . edgesToStrings)) typeEdges         `shouldBe` noDifferences    it "can find the subtypesOfType" $ do-     setDifferences (Set.fromList $(withLocalDeclarations [] $+     setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: Map Type (E Type)) $                                   runQ [t|Type|] >>= \typ ->                                   makeTypeInfo (const $ return mempty) [typ] >>= runReaderT typeGraphEdges' >>=                                   runQ . lift . List.map pprintVertex . Map.keys)) subtypesOfType         `shouldBe` noDifferences    it "can find the edges of the arity 0 subtype graph of Type (arity0TypeEdges)" $ do-     setDifferences (Set.fromList $(withLocalDeclarations [] $+     setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: Map Type (E Type)) $                                 runQ [t|Type|] >>= \typ ->                                 makeTypeInfo (const $ return mempty) [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=-                                dissolveM (\ v -> (/= 0) <$> (typeArity . runExpanded . view etype) v) >>=+                                dissolveM (\ v -> (/= 0) <$> (typeArity . unE . view etype) v) >>=                                 runQ . lift . edgesToStrings)) arity0TypeEdges         `shouldBe` noDifferences #if 0
test/Values.hs view
@@ -8,9 +8,9 @@ import Data.Set as Set (Set, empty, fromList, toList, union) import GHC.Prim -- ByteArray#, Char#, etc import Language.Haskell.TH+import Language.Haskell.TH.TypeGraph.Arity (typeArity) import Language.Haskell.TH.TypeGraph.Edges (typeGraphEdges)-import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType, markExpanded)-import Language.Haskell.TH.TypeGraph.Free (typeArity)+import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType) import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..)) import Language.Haskell.TH.Desugar (withLocalDeclarations) import Language.Haskell.TH.Instances ()
th-typegraph.cabal view
@@ -1,5 +1,5 @@ name:               th-typegraph-version:            0.23+version:            0.24 cabal-version:      >= 1.10 build-type:         Simple license:            BSD3@@ -24,24 +24,25 @@     data-default,     haskell-src-exts,     lens,-    memoize,     mtl,     set-extra,     syb,     template-haskell >= 2.10,     th-desugar,     th-orphans >= 0.10.0-  ghc-options:      -Wall-  exposed-modules:  Language.Haskell.TH.TypeGraph.Edges-                    Language.Haskell.TH.TypeGraph.Expand-                    Language.Haskell.TH.TypeGraph.Free-                    Language.Haskell.TH.TypeGraph.Graph-                    Language.Haskell.TH.TypeGraph.Info-                    Language.Haskell.TH.TypeGraph.Prelude-                    Language.Haskell.TH.TypeGraph.Shape-                    Language.Haskell.TH.TypeGraph.Stack-                    Language.Haskell.TH.TypeGraph.Unsafe-                    Language.Haskell.TH.TypeGraph.Vertex+  ghc-options: -Wall -O2+  exposed-modules:+    Language.Haskell.TH.TypeGraph.Arity+    Language.Haskell.TH.TypeGraph.Edges+    Language.Haskell.TH.TypeGraph.Expand+    Language.Haskell.TH.TypeGraph.Free+    Language.Haskell.TH.TypeGraph.HasState+    Language.Haskell.TH.TypeGraph.Prelude+    Language.Haskell.TH.TypeGraph.Shape+    Language.Haskell.TH.TypeGraph.Stack+    Language.Haskell.TH.TypeGraph.TypeGraph+    Language.Haskell.TH.TypeGraph.TypeInfo+    Language.Haskell.TH.TypeGraph.Vertex   default-language: Haskell2010  test-suite th-typegraph-tests