diff --git a/Language/Haskell/TH/TypeGraph/Arity.hs b/Language/Haskell/TH/TypeGraph/Arity.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/TH/TypeGraph/Arity.hs
@@ -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
diff --git a/Language/Haskell/TH/TypeGraph/Edges.hs b/Language/Haskell/TH/TypeGraph/Edges.hs
--- a/Language/Haskell/TH/TypeGraph/Edges.hs
+++ b/Language/Haskell/TH/TypeGraph/Edges.hs
@@ -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?
diff --git a/Language/Haskell/TH/TypeGraph/Expand.hs b/Language/Haskell/TH/TypeGraph/Expand.hs
--- a/Language/Haskell/TH/TypeGraph/Expand.hs
+++ b/Language/Haskell/TH/TypeGraph/Expand.hs
@@ -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)
diff --git a/Language/Haskell/TH/TypeGraph/Free.hs b/Language/Haskell/TH/TypeGraph/Free.hs
--- a/Language/Haskell/TH/TypeGraph/Free.hs
+++ b/Language/Haskell/TH/TypeGraph/Free.hs
@@ -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
diff --git a/Language/Haskell/TH/TypeGraph/Graph.hs b/Language/Haskell/TH/TypeGraph/Graph.hs
deleted file mode 100644
--- a/Language/Haskell/TH/TypeGraph/Graph.hs
+++ /dev/null
@@ -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 = []
-             }
diff --git a/Language/Haskell/TH/TypeGraph/HasState.hs b/Language/Haskell/TH/TypeGraph/HasState.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/TH/TypeGraph/HasState.hs
@@ -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
diff --git a/Language/Haskell/TH/TypeGraph/Info.hs b/Language/Haskell/TH/TypeGraph/Info.hs
deleted file mode 100644
--- a/Language/Haskell/TH/TypeGraph/Info.hs
+++ /dev/null
@@ -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'}
diff --git a/Language/Haskell/TH/TypeGraph/Prelude.hs b/Language/Haskell/TH/TypeGraph/Prelude.hs
--- a/Language/Haskell/TH/TypeGraph/Prelude.hs
+++ b/Language/Haskell/TH/TypeGraph/Prelude.hs
@@ -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))|]
diff --git a/Language/Haskell/TH/TypeGraph/Shape.hs b/Language/Haskell/TH/TypeGraph/Shape.hs
--- a/Language/Haskell/TH/TypeGraph/Shape.hs
+++ b/Language/Haskell/TH/TypeGraph/Shape.hs
@@ -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 #-}
diff --git a/Language/Haskell/TH/TypeGraph/Stack.hs b/Language/Haskell/TH/TypeGraph/Stack.hs
--- a/Language/Haskell/TH/TypeGraph/Stack.hs
+++ b/Language/Haskell/TH/TypeGraph/Stack.hs
@@ -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 ()
diff --git a/Language/Haskell/TH/TypeGraph/TypeGraph.hs b/Language/Haskell/TH/TypeGraph/TypeGraph.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/TH/TypeGraph/TypeGraph.hs
@@ -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 = []
+             }
diff --git a/Language/Haskell/TH/TypeGraph/TypeInfo.hs b/Language/Haskell/TH/TypeGraph/TypeInfo.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/TH/TypeGraph/TypeInfo.hs
@@ -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'}
diff --git a/Language/Haskell/TH/TypeGraph/Unsafe.hs b/Language/Haskell/TH/TypeGraph/Unsafe.hs
deleted file mode 100644
--- a/Language/Haskell/TH/TypeGraph/Unsafe.hs
+++ /dev/null
@@ -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
diff --git a/Language/Haskell/TH/TypeGraph/Vertex.hs b/Language/Haskell/TH/TypeGraph/Vertex.hs
--- a/Language/Haskell/TH/TypeGraph/Vertex.hs
+++ b/Language/Haskell/TH/TypeGraph/Vertex.hs
@@ -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 " ("] ++
diff --git a/test/Common.hs b/test/Common.hs
--- a/test/Common.hs
+++ b/test/Common.hs
@@ -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
diff --git a/test/TypeGraph.hs b/test/TypeGraph.hs
--- a/test/TypeGraph.hs
+++ b/test/TypeGraph.hs
@@ -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
diff --git a/test/Values.hs b/test/Values.hs
--- a/test/Values.hs
+++ b/test/Values.hs
@@ -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 ()
diff --git a/th-typegraph.cabal b/th-typegraph.cabal
--- a/th-typegraph.cabal
+++ b/th-typegraph.cabal
@@ -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