diff --git a/Language/Haskell/TH/TypeGraph.hs b/Language/Haskell/TH/TypeGraph.hs
deleted file mode 100644
--- a/Language/Haskell/TH/TypeGraph.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Language.Haskell.TH.TypeGraph
-    ( module Language.Haskell.TH.TypeGraph.Core
-    , module Language.Haskell.TH.TypeGraph.Expand
-    , module Language.Haskell.TH.TypeGraph.Graph
-    , module Language.Haskell.TH.TypeGraph.Info
-    , module Language.Haskell.TH.TypeGraph.Monad
-    -- , module Language.Haskell.TH.TypeGraph.Unsafe
-    , module Language.Haskell.TH.TypeGraph.Vertex
-    ) where
-
-import Language.Haskell.TH.TypeGraph.Core (FieldType(FieldType, fPos, fNameAndType), fName, fType, typeArity, pprint')
-import Language.Haskell.TH.TypeGraph.Expand (Expanded(markExpanded), runExpanded, E(E))
-import Language.Haskell.TH.TypeGraph.Graph (GraphEdges, graphFromMap, cut, cutM, isolate, isolateM, dissolve, dissolveM)
-import Language.Haskell.TH.TypeGraph.Info (TypeGraphInfo, fields, infoMap, synonyms, typeSet,
-                                           emptyTypeGraphInfo, typeGraphInfo)
-import Language.Haskell.TH.TypeGraph.Monad (vertex, allVertices, typeGraphEdges, simpleEdges, simpleVertex)
-import Language.Haskell.TH.TypeGraph.Unsafe ()
-import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex, field, syns, etype, typeNames)
diff --git a/Language/Haskell/TH/TypeGraph/Core.hs b/Language/Haskell/TH/TypeGraph/Core.hs
deleted file mode 100644
--- a/Language/Haskell/TH/TypeGraph/Core.hs
+++ /dev/null
@@ -1,176 +0,0 @@
--- | Helper functions for dealing with record fields, type shape, type
--- arity, primitive types, and pretty printing.
-{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, RankNTypes, ScopedTypeVariables, TemplateHaskell #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Haskell.TH.TypeGraph.Core
-    ( unReify
-    , unReifyName
-    -- * Declaration shape
-    , FieldType(FieldType, fPos, fNameAndType)
-    , Field
-    , fName
-    , fType
-    , constructorFields
-    , foldShape
-    -- * Constructor deconstructors
-    , constructorName
-    -- * Queries
-    , typeArity
-    -- * Pretty print without extra whitespace
-    , pprint'
-    , unlifted
-    ) where
-
-import Control.Applicative ((<$>), (<*>))
-import Data.Generics (Data, everywhere, mkT)
-import Data.Map as Map (Map, fromList, toList)
-import Data.Set as Set (Set, fromList, toList)
-import Data.Typeable (Typeable)
-import Language.Haskell.Exts.Syntax ()
-import Language.Haskell.TH
-import Language.Haskell.TH.Desugar ({- instances -})
-import Language.Haskell.TH.PprLib (ptext)
-import Language.Haskell.TH.Syntax
-import Language.Haskell.TH.TypeGraph.Expand (E, markExpanded, runExpanded)
-
--- FieldType and Field should be merged, or made less rudundant.
-
-data FieldType
-    = FieldType
-      { fPos :: Int
-      , fNameAndType :: Either StrictType VarStrictType }
-    deriving (Eq, Ord, Show, Data, Typeable)
-
-type Field = ( Name, -- type name
-               Name, -- constructor name
-               Either Int -- field position
-                      Name -- field name
-             )
-
-instance Ppr Field where
-    ppr (tname, cname, field) = ptext $
-        "field " ++
-        show (unReifyName tname) ++ "." ++
-        either (\ n -> show (unReifyName cname) ++ "[" ++ show n ++ "]") (\ f -> show (unReifyName f)) field
-
-instance Ppr () where
-    ppr () = ptext "()"
-
-unReify :: Data a => a -> a
-unReify = everywhere (mkT unReifyName)
-
-unReifyName :: Name -> Name
-unReifyName = mkName . nameBase
-
-fName :: FieldType -> Maybe Name
-fName = either (\ (_, _) -> Nothing) (\ (x, _, _) -> Just x) . fNameAndType
-
-instance Ppr FieldType where
-    ppr fld = ptext $ maybe (show (fPos fld)) nameBase (fName fld)
-
-instance Ppr (Maybe Field, E Type) where
-    ppr (mf, typ) = ptext $ pprint typ ++ maybe "" (\fld -> " (field " ++ pprint fld ++ ")") mf
-
-instance Ppr (Maybe Field, Type) where
-    ppr (mf, typ) = ptext $ pprint typ ++ " (unexpanded)" ++ maybe "" (\fld -> " (field " ++ pprint fld ++ ")") mf
-
--- | fType' with leading foralls stripped
-fType :: FieldType -> Type
-fType = either (\ (_, x) -> x) (\ (_, _, x) -> x) . fNameAndType
-
--- | Given the list of constructors from a Dec, dispatch on the
--- different levels of complexity of the type they represent - a
--- wrapper is a single arity one constructor, an enum is
--- several arity zero constructors, and so on.
-foldShape :: Monad m =>
-             ([(Con, [FieldType])] -> m r) -- dataFn - several constructors not all of which are arity zero
-          -> (Con -> [FieldType] -> m r)   -- recordFn - one constructor which has arity greater than one
-          -> ([Con] -> m r)                -- enumFn - all constructors are of arity zero
-          -> (Con -> FieldType -> m r)     -- wrapperFn - one constructor of arity one
-          -> [Con] -> m r
-foldShape dataFn recordFn enumFn wrapperFn cons =
-    case zip cons (map constructorFields cons) :: [(Con, [FieldType])] of
-      [(con, [fld])] ->
-          wrapperFn con fld
-      [(con, flds)] ->
-          recordFn con flds
-      pairs | all (== 0) (map (length . snd) pairs) ->
-          enumFn (map fst pairs)
-      pairs ->
-          dataFn pairs
-
-constructorName :: Con -> Name
-constructorName (ForallC _ _ con) = constructorName con
-constructorName (NormalC name _) = name
-constructorName (RecC name _) = name
-constructorName (InfixC _ name _) = name
-
-constructorFields :: Con -> [FieldType]
-constructorFields (ForallC _ _ con) = constructorFields con
-constructorFields (NormalC _ ts) = map (uncurry FieldType) (zip [1..] (map Left ts))
-constructorFields (RecC _ ts) = map (uncurry FieldType) (zip [1..] (map Right ts))
-constructorFields (InfixC t1 _ t2) = map (uncurry FieldType) [(1, Left t1), (2, Left t2)]
-
--- | Compute the arity of a type - the number of type parameters that
--- must be applied to it in order to obtain a concrete type.
-typeArity :: Quasi m => Type -> m Int
-typeArity (ForallT _ _ typ) = typeArity typ
-typeArity ListT = return 1
-typeArity (VarT _) = return 1
-typeArity (TupleT n) = return n
-typeArity (AppT t _) = typeArity t >>= \ n -> return $ n - 1
-typeArity (ConT name) = qReify name >>= infoArity
-    where
-      infoArity (TyConI dec) = decArity dec
-      infoArity (PrimTyConI _ _ _) = return 0
-      infoArity (FamilyI dec _) = decArity dec
-      infoArity info = error $ "typeArity - unexpected: " ++ pprint' info
-      decArity (DataD _ _ vs _ _) = return $ length vs
-      decArity (NewtypeD _ _ vs _ _) = return $ length vs
-      decArity (TySynD _ vs t) = typeArity t >>= \ n -> return $ n + length vs
-      decArity (FamilyD _ _ vs _mk) = return $ {- not sure what to do with the kind mk here -} length vs
-      decArity dec = error $ "decArity - unexpected: " ++ show dec
-typeArity typ = error $ "typeArity - unexpected type: " ++ show typ
-
--- | Pretty print a 'Ppr' value on a single line with each block of
--- white space (newlines, tabs, etc.) converted to a single space.
-pprint' :: Ppr a => a -> [Char]
-pprint' typ = unwords $ words $ pprint typ
-
-instance Lift a => Lift (Set a) where
-    lift s = [|Set.fromList $(lift (Set.toList s))|]
-
-instance (Lift a, Lift b) => Lift (Map a b) where
-    lift mp = [|Map.fromList $(lift (Map.toList mp))|]
-
-instance Lift (E Type) where
-    lift etype = [|markExpanded $(lift (runExpanded etype))|]
-
--- | Does the type or the declaration to which it refers contain a
--- primitive (aka unlifted) type?  This will traverse down any 'Dec'
--- to the named types, and then check whether any of their 'Info'
--- records are 'PrimTyConI' values.
-class IsUnlifted t where
-    unlifted :: Quasi m => t -> m Bool
-
-instance IsUnlifted Dec where
-    unlifted (DataD _ _ _ cons _) = or <$> mapM unlifted cons
-    unlifted (NewtypeD _ _ _ con _) = unlifted con
-    unlifted (TySynD _ _ typ) = unlifted typ
-    unlifted _ = return False
-
-instance IsUnlifted Con where
-    unlifted (ForallC _ _ con) = unlifted con
-    unlifted (NormalC _ ts) = or <$> mapM (unlifted . snd) ts
-    unlifted (RecC _ ts) = or <$> mapM (\ (_, _, t) -> unlifted t) ts
-    unlifted (InfixC t1 _ t2) = or <$> mapM (unlifted . snd) [t1, t2]
-
-instance IsUnlifted Type where
-    unlifted (ForallT _ _ typ) = unlifted typ
-    unlifted (ConT name) = qReify name >>= unlifted
-    unlifted (AppT t1 t2) = (||) <$> unlifted t1 <*> unlifted t2
-    unlifted _ = return False
-
-instance IsUnlifted Info where
-    unlifted (PrimTyConI _ _ _) = return True
-    unlifted _ = return False -- traversal stops here
diff --git a/Language/Haskell/TH/TypeGraph/Edges.hs b/Language/Haskell/TH/TypeGraph/Edges.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/TH/TypeGraph/Edges.hs
@@ -0,0 +1,200 @@
+-- | Operations involving the edges of the graph (before it is a graph.)
+
+{-# 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.Edges
+    ( GraphEdges
+    , typeGraphEdges
+    , cut
+    , cutM
+    , cutEdges
+    , cutEdgesM
+    , isolate
+    , isolateM
+    , link
+    , linkM
+    , dissolve
+    , dissolveM
+    , simpleEdges
+    ) where
+
+#if __GLASGOW_HASKELL__ < 709
+import Control.Applicative ((<$>))
+import Data.Monoid (mempty)
+#endif
+import Control.Lens -- (makeLenses, view)
+import Control.Monad (filterM)
+import Control.Monad.Reader (MonadReader)
+import Control.Monad.State (execStateT, modify, StateT)
+import Data.Default (Default(def))
+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)
+import qualified Data.Map as Map (toList)
+import Data.Maybe (mapMaybe)
+import Data.Monoid ((<>))
+import Data.Set as Set (delete, empty, filter, insert, map, member, fromList, Set, singleton, toList, union)
+import Language.Haskell.Exts.Syntax ()
+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.Prelude (pprint')
+import Language.Haskell.TH.TypeGraph.Vertex (simpleVertex, TGV, TGVSimple)
+import Language.Haskell.TH.Desugar as DS (DsMonad)
+import Language.Haskell.TH.Instances ()
+import Prelude hiding (foldr, mapM_, null)
+
+type GraphEdges node key = Map key (node, Set key)
+
+-- | Given the discovered set of types and maps of type synonyms and
+-- 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 node m. (DsMonad m, Functor m, Default node, MonadReader TypeInfo m) =>
+                  m (GraphEdges node TGV)
+typeGraphEdges = do
+  execStateT (view typeSet >>= mapM_ (\t -> expandType t >>= doType)) mempty
+    where
+      doType :: E Type -> StateT (GraphEdges node TGV) m ()
+      doType typ = do
+        vs <- allVertices Nothing typ
+        mapM_ node vs
+        case typ of
+          E (ConT tname) -> view infoMap >>= \ mp -> doInfo vs (mp ! tname)
+          E (AppT typ1 typ2) -> do
+            v1 <- typeVertex' (E typ1)
+            v2 <- typeVertex' (E typ2)
+            mapM_ (flip edge v1) vs
+            mapM_ (flip edge v2) vs
+            doType (E typ1)
+            doType (E typ2)
+          _ -> return ()
+
+      doInfo :: Set TGV -> Info -> StateT (GraphEdges node TGV) m ()
+      doInfo vs (TyConI dec) = doDec vs dec
+      -- doInfo vs (PrimTyConI tname _ _) = return ()
+      doInfo _ _ = return ()
+
+      doDec :: Set TGV -> Dec -> StateT (GraphEdges node TGV) m ()
+      doDec _ (TySynD _ _ _) = return () -- This type will be in typeSet
+      doDec vs (NewtypeD _ tname _ constr _) = doCon vs tname constr
+      doDec vs (DataD _ tname _ constrs _) = mapM_ (doCon vs tname) constrs
+      doDec _ _ = return ()
+
+      doCon :: Set TGV -> Name -> Con -> StateT (GraphEdges node TGV) m ()
+      doCon vs tname (ForallC _ _ con) = doCon vs tname con
+      doCon vs tname (NormalC cname flds) = mapM_ (uncurry (doField vs tname cname)) (List.map (\ (n, (_, ftype)) -> (Left n, ftype)) (zip [1..] flds))
+      doCon vs tname (RecC cname flds) = mapM_ (uncurry (doField vs tname cname)) (List.map (\ (fname, _, ftype) -> (Right fname, ftype)) flds)
+      doCon vs tname (InfixC (_, lhs) cname (_, rhs)) = doField vs tname cname (Left 1) lhs >> doField vs tname cname (Left 2) rhs
+
+      -- 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 node TGV) m ()
+      doField vs tname cname fld ftyp = do
+        v2 <- expandType ftyp >>= fieldVertex (tname, cname, fld)
+        v3 <- expandType ftyp >>= typeVertex'
+        edge v2 v3
+        mapM_ (flip edge v2) vs
+        -- Here's where we don't recurse, see?
+        -- doVertex v2
+
+      node :: TGV -> StateT (GraphEdges node TGV) m ()
+      -- node v = pass (return ((), (Map.alter (Just . maybe (def, Set.empty) id) v)))
+      node v = modify (Map.alter (Just . maybe (def, Set.empty) id) v)
+
+      edge :: TGV -> TGV -> StateT (GraphEdges node TGV) m ()
+      edge v1 v2 = node v2 >> modify f
+          where f :: GraphEdges node TGV -> GraphEdges node TGV
+                f = Map.alter g v1
+                g :: (Maybe (node, Set TGV) -> Maybe (node, Set TGV))
+                g = Just . maybe (def, singleton v2) (over _2 (Set.insert v2))
+
+instance Ppr key => Ppr (GraphEdges node key) where
+    ppr x =
+        ptext $ intercalate "\n  " $
+          "edges:" : (List.map
+                       (\(k, (_, ks)) -> intercalate "\n    " ((pprint' k ++ " ->" ++ if null ks then " []" else "") : List.map pprint' (Set.toList ks)))
+                       (Map.toList x))
+
+-- | Isolate and remove matching nodes
+cut :: (Eq a, Ord a) => (a -> Bool) -> GraphEdges node a -> GraphEdges node a
+cut p edges = Map.filterWithKey (\v _ -> not (p v)) (isolate p edges)
+
+-- | Monadic predicate version of 'cut'.
+cutM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges node a -> m (GraphEdges node a)
+cutM victim edges = do
+  victims <- Set.fromList <$> filterM victim (Map.keys edges)
+  return $ cut (flip Set.member victims) edges
+
+cutEdges :: (Eq a, Ord a) => (a -> a -> Bool) -> GraphEdges node a -> (GraphEdges node a)
+cutEdges p edges = Map.mapWithKey (\key (hint, gkeys) -> (hint, Set.filter (\gkey -> not (p key gkey)) gkeys)) edges
+
+cutEdgesM :: (Monad m, Eq a, Ord a) => (a -> a -> m Bool) -> GraphEdges node a -> m (GraphEdges node a)
+cutEdgesM p edges = do
+  let pairs = Map.toList edges
+  ss <- mapM (\(a, (_, s)) -> filterM (\b -> not <$> p a b) (Set.toList s)) pairs
+  let pairs' = List.map (\ ((a, (h, _)), s') -> (a, (h, Set.fromList s'))) (zip pairs ss)
+  return $ Map.fromList pairs'
+
+-- | Remove all the in- and out-edges of matching nodes
+isolate :: (Eq a, Ord a) => (a -> Bool) -> GraphEdges node a -> GraphEdges node a
+isolate p edges = cutEdges (\ a b -> p a || p b) edges
+
+-- | Monadic predicate version of 'isolate'.
+isolateM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges node a -> m (GraphEdges node a)
+isolateM victim edges = do
+  victims <- Set.fromList <$> filterM victim (Map.keys edges)
+  return $ isolate (flip Set.member victims) edges
+
+-- | Replace the out set of selected nodes
+link :: (Eq a, Ord a) => (a -> Maybe (Set a)) -> GraphEdges node a -> GraphEdges node a
+link f edges =
+    foldr link1 edges (List.map (\a -> (a, f a)) (Map.keys edges))
+    where
+      link1 :: (Eq a, Ord a) => (a, Maybe (Set a)) -> GraphEdges node a -> GraphEdges node a
+      link1 (_, Nothing) edges' = edges'
+      link1 (a, Just s) edges' = Map.alter (\(Just (node, _)) -> Just (node, s)) a edges'
+
+linkM :: (Eq a, Ord a, Monad m) => (a -> m (Maybe (Set a))) -> GraphEdges node a -> m (GraphEdges node a)
+linkM f edges = do
+  let ks = Map.keys edges
+  mss <- mapM f ks
+  let mp = Map.fromList $ mapMaybe (\(k, ms) -> maybe Nothing (Just .(k,)) ms) $ zip ks mss
+  return $ link (\k -> Map.lookup k mp) edges
+
+-- | Remove matching nodes and extend each of their in-edges to each of
+-- their out-edges.
+dissolve :: (Eq a, Ord a) => (a -> Bool) -> GraphEdges node a -> GraphEdges node a
+dissolve p edges =
+    foldr dissolve1 edges (List.filter p (Map.keys edges))
+    where
+      -- Remove a victim and call dissolve1' to extend the edges of each
+      -- node that had it in its out set.
+      dissolve1 v es = maybe es (\(_, s) -> dissolve1' v (Set.delete v s) (Map.delete v es)) (Map.lookup v es)
+      -- If a node's out edges include the victim replace them with next.
+      dissolve1' v vs es = Map.map (\(h, s) -> (h, if Set.member v s then Set.union vs (Set.delete v s) else s)) es
+
+-- | Monadic predicate version of 'dissolve'.
+dissolveM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges node a -> m (GraphEdges node a)
+dissolveM victim edges = do
+  victims <- Set.fromList <$> filterM victim (Map.keys edges)
+  return $ dissolve (flip Set.member victims) edges
+
+-- | Simplify a graph by throwing away the field information in each
+-- node.  This means the nodes only contain the fully expanded Type
+-- value (and any type synonyms.)
+simpleEdges :: Monoid node => GraphEdges node TGV -> GraphEdges node TGVSimple
+simpleEdges = Map.mapWithKey (\v (n, s) -> (n, Set.delete v s)) .    -- delete any self edges
+              Map.mapKeysWith combine simpleVertex .   -- simplify each vertex
+              Map.map (over _2 (Set.map simpleVertex)) -- simplify the out edges
+    where
+      combine (n1, s1) (n2, s2) = (n1 <> n2, Set.union s1 s2)
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
@@ -19,6 +19,7 @@
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Language.Haskell.TH.TypeGraph.Expand
     ( Expanded(markExpanded, runExpanded')
@@ -36,6 +37,7 @@
 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 Prelude hiding (pred)
 
 -- | This class lets us use the same expand* functions to work with
@@ -51,17 +53,17 @@
 -- | Apply the th-desugar expand function to a 'Pred' and mark it as expanded.
 -- Note that the definition of 'Pred' changed in template-haskell-2.10.0.0.
 expandPred :: (DsMonad m, Expanded Pred e)  => Pred -> m e
-#if MIN_VERSION_template_haskell(2,10,0)
+#if __GLASGOW_HASKELL__ >= 709
 expandPred = expandType
 #else
-expandPred (ClassP className typeParameters) = markExpanded <$> (ClassP className . map runExpanded) <$> mapM expandType typeParameters
+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 MIN_VERSION_template_haskell(2,10,0)
+#if __GLASGOW_HASKELL__ >= 709
       (expandType $ foldl AppT (ConT className) typeParameters) :: m e
 #else
       (markExpanded . ClassP className . map runExpanded) <$> mapM expandType typeParameters
@@ -77,7 +79,7 @@
     markExpanded = E
     runExpanded' (E x) = x
 
-#if !MIN_VERSION_template_haskell(2,10,0)
+#if __GLASGOW_HASKELL__ < 709
 instance Expanded Pred (E Pred) where
     markExpanded = E
     runExpanded' (E x) = x
@@ -85,3 +87,6 @@
 
 instance Ppr a => Ppr (E a) where
     ppr (E x) = ppr x
+
+instance Lift (E Type) where
+    lift etype = [|markExpanded $(lift (runExpanded etype))|]
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,108 +1,16 @@
 {-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, TemplateHaskell #-}
 module Language.Haskell.TH.TypeGraph.Free
     ( freeTypeVars
+    , typeArity
     ) where
 
-import Control.Applicative ((<$>))
 import Control.Lens hiding (Strict, cons)
 import Control.Monad.State (MonadState, execStateT)
 import Data.Set as Set (Set, delete, difference, empty, fromList, insert, member)
 import Language.Haskell.TH
+import Language.Haskell.TH.Desugar ({- instances -})
 import Language.Haskell.TH.Syntax (Quasi(qReify))
-import Language.Haskell.TH.TypeGraph.Core (pprint')
-
-#if 0
-data SetDifferences a = SetDifferences {unexpected :: Set a, missing :: Set a} deriving (Eq, Ord, Show)
-
-setDifferences :: Ord a => Set a -> Set a -> SetDifferences a
-setDifferences actual expected = SetDifferences {unexpected = Set.difference actual expected, missing = Set.difference expected actual}
-noDifferences = SetDifferences {unexpected = Set.empty, missing = Set.empty}
-
-unReify :: Data a => a -> a
-unReify = everywhere (mkT unReifyName)
-
-unReifyName :: Name -> Name
-unReifyName = mkName . nameBase
-
--- Some very nasty bug is triggered here in ghc-7.8 if we try to implement
--- a generic function that unReifies the symbols.  Ghc-7.10 works fine
-
--- pprint'' :: (Data a, Ppr a) => a -> String
--- pprint'' = pprint' . unReify
-
-pprintDec :: Dec -> String
-pprintDec = pprint' . unReify
-
-pprintType :: E Type -> String
-pprintType = pprint' . unReify . runExpanded
-
-pprintVertex :: TypeGraphVertex -> String
-pprintVertex = pprint'
-
-pprintPred :: E Pred -> String
-pprintPred = pprint' . unReify . runExpanded
-
-edgesToStrings :: GraphEdges label TypeGraphVertex -> [(String, [String])]
-edgesToStrings mp = List.map (\ (t, (_, s)) -> (pprintVertex t, map pprintVertex (Set.toList s))) (Map.toList mp)
-
-typeGraphInfo' :: [(Maybe Field, E Type, VertexHint)] -> [Type] -> Q (TypeGraphInfo VertexHint)
-typeGraphInfo' = typeGraphInfo
-
-typeGraphEdges' :: forall m. (DsMonad m, MonadReader (TypeGraphInfo VertexHint) m) => m (GraphEdges VertexHint TypeGraphVertex)
-typeGraphEdges' = typeGraphEdges
-
-withTypeGraphInfo' :: forall m a. DsMonad m =>
-                      [(Maybe Field, E Type, VertexHint)] -> [Type] -> ReaderT (TypeGraphInfo VertexHint) m a -> m a
-withTypeGraphInfo' = withTypeGraphInfo
-
--- | Return a mapping from vertex to all the known type synonyms for
--- the type in that vertex.
-typeSynonymMap :: forall m hint. (DsMonad m, Default hint, Eq hint, HasVertexHints hint, MonadReader (TypeGraphInfo hint) m) =>
-                  m (Map TypeGraphVertex (Set Name))
-typeSynonymMap =
-     (Map.filter (not . Set.null) .
-      Map.fromList .
-      List.map (\node -> (node, _syns node)) .
-      Map.keys) <$> typeGraphEdges
-
--- | Like 'typeSynonymMap', but with all field information removed.
-typeSynonymMapSimple :: forall m hint. (DsMonad m, Default hint, Eq hint, HasVertexHints hint, MonadReader (TypeGraphInfo hint) m) =>
-                        m (Map (E Type) (Set Name))
-typeSynonymMapSimple =
-    simplify <$> typeSynonymMap
-    where
-      simplify :: Map TypeGraphVertex (Set Name) -> Map (E Type) (Set Name)
-      simplify mp = Map.fromListWith Set.union (List.map (\ (k, a) -> (_etype k, a)) (Map.toList mp))
-#endif
-
-#if 0
-freeNamesOfTypes :: [Type] -> Set Name
-freeNamesOfTypes = mconcat . map freeNamesOfType
-
--- | This is based on the freeNamesOfTypes function from the
--- th-desugar package.  However, it has a weakness in that if
--- we encounter a type application, it may be that 
-freeNamesOfType :: Quasi m => Type -> m (Set Name)
-freeNamesOfType = go
-  where
-    go (ForallT tvbs cxt ty) = (go ty <> mconcat (map go_pred cxt))
-                               \\ Set.fromList (map tvbName tvbs)
-    go (AppT t1 t2)          = go_app [t2] t1
-    go (AppT t1 t2)          = go t1 <> go t2
-    go (SigT ty _)           = go ty
-    go (VarT n)              = Set.singleton n
-    go _                     = Set.empty
-
-#if MIN_VERSION_template_haskell(2,10,0)
-    go_pred = go
-#else
-    go_pred (ClassP _ tys) = freeNamesOfTypes tys
-    go_pred (EqualP t1 t2) = go t1 <> go t2
-#endif
-    go_app params (AppT t1 t2) = go_app (t2 : params) t1
-    go_app params (ConT n) = qReify n >>= go_info params
-    go_app params typ = concatMap go (typ : params)
-#endif
+import Language.Haskell.TH.TypeGraph.Prelude (pprint')
 
 data St
     = St { _result :: Set Name
@@ -114,6 +22,31 @@
 
 $(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
+-- by an enclosing forall or by the type parameters of a Dec.
 freeTypeVars :: (FreeTypeVars t, Quasi m) => t -> m (Set Name)
 freeTypeVars x = view result <$> execStateT (ftv x) st0
 
@@ -131,7 +64,7 @@
       mapM_ go_pred cx
       result %= (`Set.difference` (Set.fromList (map tvbName tvbs)))
         where
-#if MIN_VERSION_template_haskell(2,10,0)
+#if __GLASGOW_HASKELL__ >= 709
           go_pred typ =
               -- This looks wrong as the one below looks wrong.  Wronger maybe.
               ftv typ
@@ -220,7 +153,7 @@
 
 instance FreeTypeVars Dec where
     ftv dec@(DataD _ _ _ _ _ _) = ftv dec
-#if MIN_VERSION_template_haskell(2,10,0)
+#if __GLASGOW_HASKELL__ >= 709
     go_pred = go
 #else
     go_pred (ClassP _ tys) = freeNamesOfTypes tys
diff --git a/Language/Haskell/TH/TypeGraph/Graph.hs b/Language/Haskell/TH/TypeGraph/Graph.hs
--- a/Language/Haskell/TH/TypeGraph/Graph.hs
+++ b/Language/Haskell/TH/TypeGraph/Graph.hs
@@ -3,46 +3,73 @@
 -- FIXME: the sense of the predicates are kinda mixed up here
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Language.Haskell.TH.TypeGraph.Graph
-    ( GraphEdges
+    ( TypeGraph, typeInfo, edges, graph, gsimple
+    , TypeGraph(TypeGraph, _typeInfo, _edges, _graph, _gsimple, _stack) -- temporary
     , graphFromMap
-    , cut
-    , cutM
-    , isolate
-    , isolateM
-    , dissolve
-    , dissolveM
+
+    , allPathKeys
+    , allPathStarts
+    , reachableFrom
+    , reachableFromSimple
+    , goalReachableFull
+    , goalReachableSimple
+    , goalReachableSimple'
+
+    , makeTypeGraph
+    , VertexStatus(..)
+    , typeGraphEdges'
+    , adjacent
+    , typeGraphVertex
+    , typeGraphVertexOfField
     ) where
 
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
+#if __GLASGOW_HASKELL__ < 709
+import Control.Applicative
+import Data.Monoid (mempty)
+#else
+import Control.Applicative
 #endif
-
-import Control.Lens (over, _2)
-import Control.Monad (filterM)
+import Control.Lens -- (makeLenses, over, view)
+import Control.Monad (when)
+import Control.Monad as List (filterM)
+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 (intercalate, map)
-import Data.Map as Map (Map, elems, filterWithKey, keys, map, mapWithKey, partitionWithKey)
+import Data.List as List (map)
+import Data.Map as Map (alter, update)
 import qualified Data.Map as Map (toList)
-import Data.Set as Set (Set, delete, empty, filter, member, fromList, union, unions)
-import Language.Haskell.TH (Ppr(ppr))
+import Data.Maybe (fromJust, mapMaybe)
+import Data.Set.Extra as Set (empty, flatten, filterM, fromList, insert, map, mapM, member, Set, singleton, toList, 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.TypeGraph.Core (pprint')
-import Prelude hiding (foldr)
-
-type GraphEdges node key = Map key (node, Set key)
+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))
+import Language.Haskell.TH.TypeGraph.Stack (HasStack(withStack, push), StackElement(StackElement))
+import Language.Haskell.TH.TypeGraph.Vertex (simpleVertex, TGV, TGVSimple, vsimple, TypeGraphVertex, etype)
+import Prelude hiding (any, concat, concatMap, elem, exp, foldr, mapM_, null, or)
 
-instance Ppr key => Ppr (GraphEdges node key) where
-    ppr x =
-        ptext $ intercalate "\n  " $
-          "edges:" : (List.map
-                       (\(k, (_, ks)) -> intercalate "\n    " ((pprint' k ++ " ->") : List.map pprint' (toList ks)))
-                       (Map.toList x))
+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
@@ -54,51 +81,218 @@
     graphFromEdges triples
     where
       triples :: [(node, key, [key])]
-      triples = List.map (\ (k, (node, ks)) -> (node, k, toList ks)) $ Map.toList mp
+      triples = List.map (\ (k, (node, ks)) -> (node, k, Foldable.toList ks)) $ Map.toList mp
 
--- | Isolate and remove some nodes
-cut :: (Eq a, Ord a) => Set a -> GraphEdges node a -> GraphEdges node a
-cut victims edges = Map.filterWithKey (\v _ -> not (Set.member v victims)) (isolate victims edges)
+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] -- this is the only type that isn't available in th-typegraph
+      }
 
--- | Monadic predicate version of 'cut'.
-cutM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges node a -> m (GraphEdges node a)
-cutM victim edges = do
-  victims <- Set.fromList <$> filterM victim (Map.keys edges)
-  return $ cut victims edges
+$(makeLenses ''TypeGraph)
 
--- | Remove all the in- and out-edges of some nodes
-isolate :: (Eq a, Ord a) => Set a -> GraphEdges node a -> GraphEdges node a
-isolate victims edges =
-    edges''
+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
+
+#if 0
+-- | All the types for which we will generate Path types, along with
+-- the corresponding set of goal types.
+allKeys :: (DsMonad m, MonadReader TypeGraph m) => m (Set (TGV, Set TGV, Set TGV))
+allKeys = do
+  (g, vf, kf) <- view graph
+  -- (gs, vfs, kfs) <- view gsimple
+  ti <- view typeInfo
+  st <- runReaderT (Traversable.mapM expandType (view startTypes ti) >>= Traversable.mapM (vertex Nothing)) ti
+  let st' = mapMaybe kf st
+  let pt = Set.fromList $ concatMap (reachable g) st'
+      pt' = Set.map (\(_, key, _) -> key) . Set.map vf $ pt
+      pt'' = Set.map simpleVertex pt'
+  Set.mapM (\t -> do goals <- Set.filterM (\g -> goalReachableSimple g t) pt''
+                     let Just v = vf t
+                         (_, _, adjacent) <- kf v
+                     return (t, Set.fromList adjacent, goals)) pt''
+
+allPathKeys :: (DsMonad m, MonadReader TypeGraph m) => m (Set (TGV, TGV))
+allPathKeys = (Set.flatten . Set.map (\ (t, s) -> Set.map (t,) s)) <$> allKeys
+
+allPathStarts :: forall m. (DsMonad m, MonadReader TypeGraph m) => m (Set TGV)
+allPathStarts = Set.map fst <$> allKeys
+#else
+allPathKeys :: (DsMonad m, MonadReader TypeGraph m) => m (Set (TGV, TGV))
+allPathKeys = do
+  pathKeys <- allPathStarts
+  Set.fromList <$> List.filterM (uncurry goalReachableSimple') [ (g, k) | g <- Foldable.toList pathKeys,
+                                                                          k <- Foldable.toList pathKeys ]
+
+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 kernel' = mapMaybe kf kernel
+  let keep = Set.fromList $ concatMap (reachable g) kernel'
+      keep' = Set.map (\(_, key, _) -> key) . Set.map vf $ keep
+  return keep'
+#endif
+
+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 (simpleVertex gkey) (simpleVertex 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)
+
+#if 0
+  es <- view edges
+  let Just v0 = 
+      Just vf = 
+  return $ 
+  case kf key0 of
+    Nothing -> error ("isReachable - unknown key: " ++ pprint' key0)
+    Just key -> do
+      let gvert = fromMaybe (error $ "Unknown goal type: " ++ pprint' gkey ++ "\n" ++ intercalate "\n  " ("known:" : List.map pprint' (Map.keys es))) (kf gkey)
+      -- Can we reach any node whose type matches (ConT gname)?  Fields don't matter.
+      return $ path g key gvert
+#endif
+
+-- | 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
-      edges' = Map.mapWithKey (\v (h, s) -> (h, if Set.member v victims then Set.empty else s)) edges -- Remove the out-edges
-      edges'' = Map.map (over _2 (Set.filter (not . (`Set.member` victims)))) edges' -- Remove the in-edges
+      doNode v = do
+        s <- lift $ getSet
+        when (not (member v s)) $
+             do lift $ modifySet (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)
 
--- | Monadic predicate version of 'isolate'.
-isolateM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges node a -> m (GraphEdges node a)
-isolateM victim edges = do
-  victims <- Set.fromList <$> filterM victim (Map.keys edges)
-  return $ isolate victims edges
+      addNode :: TGV -> StateT (GraphEdges () TGV) m ()
+      addNode a = modify $ Map.alter (maybe (Just (def, Set.empty)) Just) a
 
--- | Remove some nodes and extend each of their in-edges to each of
--- their out-edges
-dissolve :: (Eq a, Ord a) => Set a -> GraphEdges node a -> GraphEdges node a
-dissolve victims edges0 = foldr dissolve1 edges0 victims
+      addEdge :: TGV -> TGV -> StateT (GraphEdges () TGV) m ()
+      addEdge a b = modify $ Map.update (\(lbl, s) -> Just (lbl, 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
-      dissolve1 :: (Eq a, Ord a) => a -> GraphEdges node a -> GraphEdges node a
-      dissolve1 victim edges =
-          -- Wherever the victim vertex appears as an out-edge, substitute the vOut set
-          Map.mapWithKey (\k (h, s) -> (h, extend k s)) survivorEdges
-          where
-            -- Extend the out edges of one node through dissolved node v
-            extend k s = if Set.member victim s then Set.union (Set.delete victim s) (Set.delete k vOut) else s
-            -- Get the out-edges of the victim vertex (omitting self edges)
-            vOut = Set.delete victim $ Set.unions $ List.map snd $ Map.elems victimEdges
-            -- Split map into victim vertex and other vertices
-            (victimEdges, survivorEdges) = partitionWithKey (\v _ -> (v == victim)) edges
+      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
 
--- | Monadic predicate version of 'dissolve'.
-dissolveM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges node a -> m (GraphEdges node a)
-dissolveM victim edges = do
-  victims <- Set.fromList <$> filterM victim (Map.keys edges)
-  return $ dissolve victims edges
+      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 :: (DsMonad m) => ReaderT TypeInfo m (GraphEdges () TGV) -> TypeInfo -> m TypeGraph
+makeTypeGraph makeTypeGraphEdges ti = do
+  -- ti <- typeInfo st
+  es <- runReaderT makeTypeGraphEdges ti
+  return $ TypeGraph
+             { _typeInfo = ti
+             , _edges = es
+             , _graph = graphFromMap es
+             , _gsimple = graphFromMap (simpleEdges es)
+             , _stack = []
+             }
diff --git a/Language/Haskell/TH/TypeGraph/Info.hs b/Language/Haskell/TH/TypeGraph/Info.hs
--- a/Language/Haskell/TH/TypeGraph/Info.hs
+++ b/Language/Haskell/TH/TypeGraph/Info.hs
@@ -10,34 +10,45 @@
 {-# LANGUAGE TupleSections #-}
 {-# OPTIONS_GHC -Wall #-}
 module Language.Haskell.TH.TypeGraph.Info
-    ( TypeGraphInfo
-    , emptyTypeGraphInfo
-    , typeGraphInfo
-    , fields, infoMap, synonyms, typeSet
+    ( -- * 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 Data.List as List (intercalate, map)
-import Data.Map as Map (insert, insertWith, Map, toList)
-import Data.Set as Set (insert, member, Set, singleton, toList, union)
+import Data.Map as Map (findWithDefault, insert, insertWith, Map, toList)
+import Data.Set as Set (empty, insert, map, member, Set, singleton, toList, union)
 import Language.Haskell.Exts.Syntax ()
 import Language.Haskell.TH
-import Language.Haskell.TH.TypeGraph.Core (pprint')
-import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)
 import Language.Haskell.TH.Desugar as DS (DsMonad)
 import Language.Haskell.TH.Instances ()
 import Language.Haskell.TH.PprLib (ptext)
 import Language.Haskell.TH.Syntax (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 TypeGraphInfo
-    = TypeGraphInfo
-      { _typeSet :: Set Type
+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
@@ -50,9 +61,9 @@
       -- ^ Map from field type to field names
       } deriving (Show, Eq, Ord)
 
-instance Ppr TypeGraphInfo where
-    ppr (TypeGraphInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f}) =
-        ptext $ intercalate "\n  " ["TypeGraphInfo:", ppt, ppi, ppe, pps, ppf] ++ "\n"
+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))
@@ -60,27 +71,25 @@
           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 ''TypeGraphInfo)
-
-instance Lift TypeGraphInfo where
-    lift (TypeGraphInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f}) =
-        [| TypeGraphInfo { _typeSet = $(lift t)
-                         , _infoMap = $(lift i)
-                         , _expanded = $(lift e)
-                         , _synonyms = $(lift s)
-                         , _fields = $(lift f)
-                         } |]
+$(makeLenses ''TypeInfo)
 
-emptyTypeGraphInfo :: TypeGraphInfo
-emptyTypeGraphInfo = TypeGraphInfo {_typeSet = mempty, _infoMap = mempty, _expanded = mempty, _synonyms = mempty, _fields = mempty}
+instance Lift TypeInfo where
+    lift (TypeInfo {_startTypes = st, _typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f}) =
+        [| TypeInfo { _startTypes = $(lift st)
+                    , _typeSet = $(lift t)
+                    , _infoMap = $(lift i)
+                    , _expanded = $(lift e)
+                    , _synonyms = $(lift s)
+                    , _fields = $(lift f)
+                    } |]
 
 -- | Collect the graph information for one type and all the types
 -- reachable from it.
-collectTypeInfo :: forall m. DsMonad m => Type -> StateT TypeGraphInfo m ()
+collectTypeInfo :: forall m. DsMonad m => Type -> StateT TypeInfo m ()
 collectTypeInfo typ0 = do
   doType typ0
     where
-      doType :: Type -> StateT TypeGraphInfo m ()
+      doType :: Type -> StateT TypeInfo m ()
       doType typ = do
         (s :: Set Type) <- use typeSet
         case Set.member typ s of
@@ -91,7 +100,7 @@
                       -- expanded %= Map.insert etyp' etyp -- A type is its own expansion, but we shouldn't need this
                       doType' typ
 
-      doType' :: Type -> StateT TypeGraphInfo m ()
+      doType' :: Type -> StateT TypeInfo m ()
       doType' (ConT name) = do
         info <- qReify name
         infoMap %= Map.insert name info
@@ -100,35 +109,79 @@
       doType' ListT = return ()
       doType' (VarT _) = return ()
       doType' (TupleT _) = return ()
-      doType' typ = error $ "typeGraphInfo: " ++ pprint' typ
+      doType' typ = error $ "makeTypeInfo: " ++ pprint' typ
 
-      doInfo :: Name -> Info -> StateT TypeGraphInfo m ()
+      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 $ "typeGraphInfo: " ++ show info
+      doInfo _ info = error $ "makeTypeInfo: " ++ show info
 
-      doDec :: Dec -> StateT TypeGraphInfo m ()
+      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 _) = mapM_ (doCon tname) constrs
-      doDec dec = error $ "typeGraphInfo: " ++ pprint' dec
+      doDec dec = error $ "makeTypeInfo: " ++ pprint' dec
 
-      doCon :: Name -> Con -> StateT TypeGraphInfo m ()
+      doCon :: Name -> Con -> StateT TypeInfo m ()
       doCon tname (ForallC _ _ con) = doCon tname con
       doCon tname (NormalC cname flds) = mapM_ doField (zip (List.map (\n -> (tname, cname, Left n)) ([1..] :: [Int])) (List.map snd flds))
       doCon tname (RecC cname flds) = mapM_ doField (List.map (\ (fname, _, ftype) -> ((tname, cname, Right fname), ftype)) flds)
       doCon tname (InfixC (_, lhs) cname (_, rhs)) = mapM_ doField [((tname, cname, Left 1), lhs), ((tname, cname, Left 2), rhs)]
 
-      doField :: ((Name, Name, Either Int Name), Type) -> StateT TypeGraphInfo m ()
+      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 TypeGraphInfo value by scanning the supplied types
-typeGraphInfo :: forall m. DsMonad m => [Type] -> m TypeGraphInfo
-typeGraphInfo types = flip execStateT emptyTypeGraphInfo $ mapM_ collectTypeInfo types
+-- | Build a TypeInfo value by scanning the supplied types
+makeTypeInfo :: forall m. DsMonad m => [Type] -> m TypeInfo
+makeTypeInfo types =
+    execStateT
+      (mapM_ collectTypeInfo 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/Monad.hs b/Language/Haskell/TH/TypeGraph/Monad.hs
deleted file mode 100644
--- a/Language/Haskell/TH/TypeGraph/Monad.hs
+++ /dev/null
@@ -1,150 +0,0 @@
--- | Operations using @MonadReader (TypeGraphInfo hint)@.
-
-{-# 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.Monad
-    ( fieldVertices
-    , allVertices
-    , vertex
-    , typeVertex
-    , fieldVertex
-    , typeGraphEdges
-    , simpleEdges
-    , simpleVertex
-    ) where
-
-#if __GLASGOW_HASKELL__ < 709
-import Control.Applicative ((<$>))
-import Data.Monoid (mempty)
-#endif
-import Control.Lens -- (makeLenses, view)
-import Control.Monad.Reader (MonadReader)
-import Control.Monad.State (execStateT, modify, StateT)
-import Data.Default (Default(def))
-import Data.Foldable
-import Data.List as List (map)
-import Data.Map as Map ((!), alter, findWithDefault, map, mapKeysWith, mapWithKey)
-import Data.Monoid (Monoid, (<>))
-import Data.Set as Set (delete, empty, insert, map, Set, singleton, union)
-import Language.Haskell.Exts.Syntax ()
-import Language.Haskell.TH -- (Con, Dec, nameBase, Type)
-import Language.Haskell.TH.TypeGraph.Core (Field)
-import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)
-import Language.Haskell.TH.TypeGraph.Graph (GraphEdges)
-import Language.Haskell.TH.TypeGraph.Info (TypeGraphInfo, fields, infoMap, synonyms, typeSet)
-import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..), etype, field)
-import Language.Haskell.TH.Desugar as DS (DsMonad)
-import Language.Haskell.TH.Instances ()
-import Prelude hiding (foldr, mapM_, null)
-
-allVertices :: (Functor m, DsMonad m, MonadReader TypeGraphInfo m) =>
-               Maybe Field -> E Type -> m (Set TypeGraphVertex)
-allVertices (Just fld) etyp = singleton <$> vertex (Just fld) etyp
-allVertices Nothing etyp = vertex Nothing etyp >>= \v -> fieldVertices v >>= \vs -> return $ Set.insert v vs
-
--- | Build 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 TypeGraphInfo m => TypeGraphVertex -> m (Set TypeGraphVertex)
-fieldVertices v = do
-  fm <- view fields
-  let fs = Map.findWithDefault Set.empty (view etype v) fm
-  return $ Set.map (\fld' -> set field (Just fld') v) fs
-
--- | Build a vertex from the given 'Type' and optional 'Field'.
-vertex :: forall m. (DsMonad m, MonadReader TypeGraphInfo m) => Maybe Field -> E Type -> m TypeGraphVertex
-vertex fld etyp = maybe (typeVertex etyp) (fieldVertex etyp) fld
-
--- | Build a non-field vertex
-typeVertex :: MonadReader TypeGraphInfo m => E Type -> m TypeGraphVertex
-typeVertex etyp = do
-  sm <- view synonyms
-  return $ TypeGraphVertex {_field = Nothing, _syns = Map.findWithDefault Set.empty etyp sm, _etype = etyp}
-
--- | Build a vertex associated with a field
-fieldVertex :: MonadReader TypeGraphInfo m => E Type -> Field -> m TypeGraphVertex
-fieldVertex etyp fld' = typeVertex etyp >>= \v -> return $ v {_field = Just fld'}
-
--- | Given the discovered set of types and maps of type synonyms and
--- 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 hint m. (DsMonad m, Functor m, Default hint, MonadReader TypeGraphInfo m) =>
-                  m (GraphEdges hint TypeGraphVertex)
-typeGraphEdges = do
-  execStateT (view typeSet >>= \ts -> mapM_ (\t -> expandType t >>= doType) ts) mempty
-    where
-      doType :: E Type -> StateT (GraphEdges hint TypeGraphVertex) m ()
-      doType typ = do
-        vs <- allVertices Nothing typ
-        mapM_ node vs
-        case typ of
-          E (ConT tname) -> view infoMap >>= \ mp -> doInfo vs (mp ! tname)
-          E (AppT typ1 typ2) -> do
-            v1 <- vertex Nothing (E typ1)
-            v2 <- vertex Nothing (E typ2)
-            mapM_ (flip edge v1) vs
-            mapM_ (flip edge v2) vs
-            doType (E typ1)
-            doType (E typ2)
-          _ -> return ()
-
-      doInfo :: Set TypeGraphVertex -> Info -> StateT (GraphEdges hint TypeGraphVertex) m ()
-      doInfo vs (TyConI dec) = doDec vs dec
-      -- doInfo vs (PrimTyConI tname _ _) = return ()
-      doInfo _ _ = return ()
-
-      doDec :: Set TypeGraphVertex -> Dec -> StateT (GraphEdges hint TypeGraphVertex) m ()
-      doDec _ (TySynD _ _ _) = return () -- This type will be in typeSet
-      doDec vs (NewtypeD _ tname _ constr _) = doCon vs tname constr
-      doDec vs (DataD _ tname _ constrs _) = mapM_ (doCon vs tname) constrs
-      doDec _ _ = return ()
-
-      doCon :: Set TypeGraphVertex -> Name -> Con -> StateT (GraphEdges hint TypeGraphVertex) m ()
-      doCon vs tname (ForallC _ _ con) = doCon vs tname con
-      doCon vs tname (NormalC cname flds) = mapM_ (uncurry (doField vs tname cname)) (List.map (\ (n, (_, ftype)) -> (Left n, ftype)) (zip [1..] flds))
-      doCon vs tname (RecC cname flds) = mapM_ (uncurry (doField vs tname cname)) (List.map (\ (fname, _, ftype) -> (Right fname, ftype)) flds)
-      doCon vs tname (InfixC (_, lhs) cname (_, rhs)) = doField vs tname cname (Left 1) lhs >> doField vs tname cname (Left 2) rhs
-
-      -- Connect the vertex for this record type to one particular field vertex
-      doField ::  DsMonad m => Set TypeGraphVertex -> Name -> Name -> Either Int Name -> Type -> StateT (GraphEdges hint TypeGraphVertex) m ()
-      doField vs tname cname fld ftyp = do
-        v2 <- expandType ftyp >>= vertex (Just (tname, cname, fld))
-        v3 <- expandType ftyp >>= vertex Nothing
-        edge v2 v3
-        mapM_ (flip edge v2) vs
-        -- Here's where we don't recurse, see?
-        -- doVertex v2
-
-      node :: TypeGraphVertex -> StateT (GraphEdges hint TypeGraphVertex) m ()
-      node v = modify (Map.alter (Just . maybe (def, Set.empty) id) v)
-
-      edge :: TypeGraphVertex -> TypeGraphVertex -> StateT (GraphEdges hint TypeGraphVertex) m ()
-      edge v1 v2 = modify f >> node v2
-          where f :: GraphEdges hint TypeGraphVertex -> GraphEdges hint TypeGraphVertex
-                f = Map.alter g v1
-                g :: (Maybe (hint, Set TypeGraphVertex) -> Maybe (hint, Set TypeGraphVertex))
-                g = Just . maybe (def, singleton v2) (over _2 (Set.insert v2))
-
--- | Simplify a graph by throwing away the field information in each
--- node.  This means the nodes only contain the fully expanded Type
--- value (and any type synonyms.)
-simpleEdges :: Monoid hint => GraphEdges hint TypeGraphVertex -> GraphEdges hint TypeGraphVertex
-simpleEdges = Map.mapWithKey (\v (n, s) -> (n, Set.delete v s)) .    -- delete any self edges
-              Map.mapKeysWith combine simpleVertex .   -- simplify each vertex
-              Map.map (over _2 (Set.map simpleVertex)) -- simplify the out edges
-    where
-      combine (n1, s1) (n2, s2) = (n1 <> n2, Set.union s1 s2)
-
-simpleVertex :: TypeGraphVertex -> TypeGraphVertex
-simpleVertex v = v {_field = Nothing}
diff --git a/Language/Haskell/TH/TypeGraph/Prelude.hs b/Language/Haskell/TH/TypeGraph/Prelude.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/TH/TypeGraph/Prelude.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+module Language.Haskell.TH.TypeGraph.Prelude
+    ( pprint'
+    , unlifted
+    , constructorName
+    , declarationName
+    , declarationType
+    , HasSet(getSet, modifySet)
+    , unReify
+    , unReifyName
+    , adjacent'
+    , reachable'
+    ) where
+
+import Control.Lens
+import Data.Generics (Data, everywhere, mkT)
+import Data.Graph as Graph
+import Data.Map as Map (Map, fromList, toList)
+import Data.Maybe (fromMaybe)
+import Data.Set as Set (fromList, Set, toList)
+import Language.Haskell.TH
+import Language.Haskell.TH.PprLib (ptext)
+import Language.Haskell.TH.Syntax (Lift(lift), Quasi(qReify))
+
+instance Ppr () where
+    ppr () = ptext "()"
+
+-- | Pretty print a 'Ppr' value on a single line with each block of
+-- white space (newlines, tabs, etc.) converted to a single space.
+pprint' :: Ppr a => a -> [Char]
+pprint' typ = unwords $ words $ pprint typ
+
+-- | Does the type or the declaration to which it refers contain a
+-- primitive (aka unlifted) type?  This will traverse down any 'Dec'
+-- to the named types, and then check whether any of their 'Info'
+-- records are 'PrimTyConI' values.
+class IsUnlifted t where
+    unlifted :: Quasi m => t -> m Bool
+
+instance IsUnlifted Dec where
+    unlifted (DataD _ _ _ cons _) = or <$> mapM unlifted cons
+    unlifted (NewtypeD _ _ _ con _) = unlifted con
+    unlifted (TySynD _ _ typ) = unlifted typ
+    unlifted _ = return False
+
+instance IsUnlifted Con where
+    unlifted (ForallC _ _ con) = unlifted con
+    unlifted (NormalC _ ts) = or <$> mapM (unlifted . snd) ts
+    unlifted (RecC _ ts) = or <$> mapM (\ (_, _, t) -> unlifted t) ts
+    unlifted (InfixC t1 _ t2) = or <$> mapM (unlifted . snd) [t1, t2]
+
+instance IsUnlifted Type where
+    unlifted (ForallT _ _ typ) = unlifted typ
+    unlifted (ConT name) = qReify name >>= unlifted
+    unlifted (AppT t1 t2) = (||) <$> unlifted t1 <*> unlifted t2
+    unlifted _ = return False
+
+instance IsUnlifted Info where
+    unlifted (PrimTyConI _ _ _) = return True
+    unlifted _ = return False -- traversal stops here
+
+constructorName :: Con -> Name
+constructorName (ForallC _ _ con) = constructorName con
+constructorName (NormalC name _) = name
+constructorName (RecC name _) = name
+constructorName (InfixC _ name _) = name
+
+declarationName :: Dec -> Maybe Name
+declarationName (FunD name _) = Just name
+declarationName (ValD _pat _body _decs) = Nothing
+declarationName (DataD _ name _ _ _) = Just name
+declarationName (NewtypeD _ name _ _ _) = Just name
+declarationName (TySynD name _ _) = Just name
+declarationName (ClassD _ name _ _ _) = Just name
+declarationName (InstanceD _ _ _) = Nothing
+declarationName (SigD name _) = Just name
+declarationName (ForeignD _) = Nothing
+declarationName (InfixD _ name) = Just name
+declarationName (PragmaD _) = Nothing
+declarationName (FamilyD _ _name _ _) = Nothing
+declarationName (DataInstD _ name _ _ _) = Just name
+declarationName (NewtypeInstD _ name _ _ _) = Just name
+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))|]
+
+instance (Lift a, Lift b) => Lift (Map a b) where
+    lift mp = [|Map.fromList $(lift (Map.toList mp))|]
+
+unReify :: Data a => a -> a
+unReify = everywhere (mkT unReifyName)
+
+unReifyName :: Name -> Name
+unReifyName = mkName . nameBase
+
+-- | Return a key's list of adjacent keys
+adjacent' :: forall node key. (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) -> key -> [key]
+adjacent' (_, vf, kf) k =
+    view _3 $ vf v
+    where
+      v = fromMaybe (error "Language.Haskell.TH.TypeGraph.Prelude.adjacent") (kf k)
+
+-- | Return a key's list of reachable keys
+reachable' :: forall node key. (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) -> key -> [key]
+reachable' (g, vf, kf) k =
+    map (view _2 . vf) $ reachableVerts
+    where
+      reachableVerts = Graph.reachable g v
+      v = fromMaybe (error "Language.Haskell.TH.TypeGraph.Prelude.reachable") (kf k)
diff --git a/Language/Haskell/TH/TypeGraph/Shape.hs b/Language/Haskell/TH/TypeGraph/Shape.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/TH/TypeGraph/Shape.hs
@@ -0,0 +1,98 @@
+-- | A fold on the shape of a record.
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+module Language.Haskell.TH.TypeGraph.Shape
+    ( 
+    -- * Field name and position
+      Field
+    , constructorFields
+    , FieldType(..)
+    , constructorFieldTypes
+    , fPos
+    , fName
+    , fType
+    -- * Decl shape
+    , foldShape
+    ) where
+
+import Data.Generics (Data)
+import Data.Typeable (Typeable)
+import Language.Haskell.Exts.Syntax ()
+import Language.Haskell.TH
+import Language.Haskell.TH.Desugar ({- instances -})
+import Language.Haskell.TH.PprLib (ptext)
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.TypeGraph.Prelude (unReifyName)
+import Language.Haskell.TH.TypeGraph.Expand (E)
+
+-- FieldType and Field should be merged, or made less rudundant.
+
+type Field = ( Name, -- type name
+               Name, -- constructor name
+               Either Int -- field position
+                      Name -- field name
+             )
+
+constructorFields :: Name -> Con -> [Field]
+constructorFields tname (ForallC _ _ con) = constructorFields tname con
+constructorFields tname (NormalC cname fields) = map (\(i, _) -> (tname, cname, Left i)) (zip ([1..] :: [Int]) fields)
+constructorFields tname (RecC cname fields) = map (\ (fname, _, _typ) -> (tname, cname, Right fname)) fields
+constructorFields tname (InfixC (_, _lhs) cname (_, _rhs)) = [(tname, cname, Left 1), (tname, cname, Left 2)]
+
+instance Ppr Field where
+    ppr (tname, cname, field) = ptext $
+        "field " ++
+        show (unReifyName tname) ++ "." ++
+        either (\ n -> show (unReifyName cname) ++ "[" ++ show n ++ "]") (\ f -> show (unReifyName f)) field
+
+instance Ppr (Maybe Field, E Type) where
+    ppr (mf, typ) = ptext $ pprint typ ++ maybe "" (\fld -> " (field " ++ pprint fld ++ ")") mf
+
+instance Ppr (Maybe Field, Type) where
+    ppr (mf, typ) = ptext $ pprint typ ++ " (unexpanded)" ++ maybe "" (\fld -> " (field " ++ pprint fld ++ ")") mf
+
+data FieldType = Positional Int StrictType | Named VarStrictType deriving (Eq, Ord, Show, Data, Typeable)
+
+instance Ppr FieldType where
+    ppr (Positional x _) = ptext $ show x
+    ppr (Named (x, _, _)) = ptext $ nameBase x
+
+fPos :: FieldType -> Either Int Name
+fPos = fName
+
+fName :: FieldType -> Either Int Name
+fName (Positional x _) = Left x
+fName (Named (x, _, _)) = Right x
+
+fType :: FieldType -> Type
+fType (Positional _ (_, x)) = x
+fType (Named (_, _, x)) = x
+
+-- | Given the list of constructors from a Dec, dispatch on the
+-- different levels of complexity of the type they represent - a
+-- wrapper is a single arity one constructor, an enum is
+-- several arity zero constructors, and so on.
+foldShape :: Monad m =>
+             ([(Con, [FieldType])] -> m r) -- dataFn - several constructors not all of which are arity zero
+          -> (Con -> [FieldType] -> m r)   -- recordFn - one constructor which has arity greater than one
+          -> ([Con] -> m r)                -- enumFn - all constructors are of arity zero
+          -> (Con -> FieldType -> m r)     -- wrapperFn - one constructor of arity one
+          -> [Con] -> m r
+foldShape dataFn recordFn enumFn wrapperFn cons =
+    case zip cons (map constructorFieldTypes cons) :: [(Con, [FieldType])] of
+      [(con, [fld])] ->
+          wrapperFn con fld
+      [(con, flds)] ->
+          recordFn con flds
+      pairs | all (== 0) (map (length . snd) pairs) ->
+          enumFn (map fst pairs)
+      pairs ->
+          dataFn pairs
+
+constructorFieldTypes :: Con -> [FieldType]
+constructorFieldTypes (ForallC _ _ con) = constructorFieldTypes con
+constructorFieldTypes (NormalC _ ts) = map (uncurry Positional) (zip [1..] ts)
+constructorFieldTypes (RecC _ ts) = map Named ts
+constructorFieldTypes (InfixC t1 _ t2) = [Positional 1 t1, Positional 2 t2]
diff --git a/Language/Haskell/TH/TypeGraph/Stack.hs b/Language/Haskell/TH/TypeGraph/Stack.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/TH/TypeGraph/Stack.hs
@@ -0,0 +1,202 @@
+-- | The HasStack monad used in MIMO to construct lenses that look
+-- deep into a record type.  However, it does not involve the Path
+-- type mechanism, and is unaware of View instances and other things
+-- that modify the type graph.  Lets see how it adapts.
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wall #-}
+module Language.Haskell.TH.TypeGraph.Stack
+    ( HasStack(push, withStack)
+    , StackElement(..)
+    , prettyStack
+    , foldField
+      -- * Stack+instance map monad
+    , StackT
+    , execStackT
+      -- * Stack operations
+    , stackAccessor
+    , makeLenses'
+    , traceIndented
+    ) where
+
+import Control.Applicative
+import Control.Category ((.))
+import Control.Lens (iso, Lens', lens, set, view)
+import Control.Monad.Reader (ReaderT, runReaderT, ask, local)
+import Control.Monad.RWS (RWST)
+import Control.Monad.State (StateT, evalStateT, get)
+import Control.Monad.Trans (lift)
+import Control.Monad.Writer (WriterT, runWriterT, execWriterT, tell)
+import Data.Char (toUpper)
+import Data.Generics (Data, Typeable)
+import Data.Map as Map (keys)
+import Data.Maybe (fromMaybe)
+import Data.Monoid
+import Debug.Trace (trace)
+import Language.Haskell.Exts.Syntax ()
+import Language.Haskell.TH
+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.Prelude (constructorName)
+import Language.Haskell.TH.TypeGraph.Shape (FieldType(..), fName, fType, constructorFieldTypes)
+import Language.Haskell.TH.TypeGraph.Vertex (etype, TGV)
+import Prelude hiding ((.))
+
+-- | The information required to extact a field value from a value.
+-- We keep a stack of these as we traverse a declaration.  Generally,
+-- we only need the field names.
+data StackElement = StackElement FieldType Con Dec deriving (Eq, Show, Data, Typeable)
+
+class Monad m => HasStack m where
+    withStack :: ([StackElement] -> m a) -> m a -- Better name: askStack
+    push :: FieldType -> Con -> Dec -> m a -> m a -- Better name: localStack
+
+instance (Quasi m, Monoid w) => HasStack (RWST [StackElement] w s m) where
+    withStack f = ask >>= f
+    push fld con dec action = local (\ stk -> StackElement fld con dec : stk) action
+
+instance HasStack m => HasStack (StateT s m) where
+    withStack f = lift (withStack return) >>= f
+    push fld con dec action = get >>= \ st -> lift $ push fld con dec (evalStateT action st)
+
+instance Quasi m => HasStack (ReaderT [StackElement] m) where
+    withStack f = ask >>= f
+    push fld con dec action = local (\ stk -> StackElement fld con dec : stk) action
+
+instance (HasStack m, Monoid w) => HasStack (WriterT w m) where
+    withStack f = lift (withStack return) >>= f
+    push fld con dec action =
+        do (r, w') <- lift $ push fld con dec (runWriterT action)
+           tell w'
+           return r
+
+traceIndented :: HasStack m => String -> m ()
+traceIndented s = withStack $ \stk -> trace (replicate (length stk) ' ' ++ s) (return ())
+
+prettyStack :: [StackElement] -> String
+prettyStack = prettyStack' . reverse
+    where
+      prettyStack' :: [StackElement] -> String
+      prettyStack' [] = "(empty)"
+      prettyStack' (x : xs) = "[" ++ prettyElt x ++ prettyTail xs ++ "]"
+      prettyTail [] = ""
+      prettyTail (x : xs) = " → " ++ prettyElt x ++ prettyTail xs
+      prettyElt (StackElement fld con dec) = prettyDec dec ++ ":" ++ prettyCon con ++ "." ++ pprint fld
+      prettyDec (TySynD _ _ typ) = prettyType typ
+      prettyDec (NewtypeD _ name _ _ _) = nameBase name
+      prettyDec (DataD _ name _ _ _) = nameBase name
+      prettyDec dec = error $ "prettyStack: " ++ show dec
+      prettyCon = nameBase . constructorName
+      prettyType (AppT t1 t2) = "((" ++ prettyType t1 ++ ") (" ++ prettyType t2 ++ "))"
+      prettyType (ConT name) = nameBase name
+      prettyType typ = "(" ++ show typ ++ ")"
+
+-- | Push the stack and process the field.
+foldField :: HasStack m => (FieldType -> m r) -> Dec -> Con -> FieldType -> m r
+foldField doField dec con fld = push fld con dec $ doField fld
+
+type StackT m = ReaderT [StackElement] m
+
+execStackT :: Monad m => StackT m a -> m a
+execStackT action = runReaderT action []
+
+-- | Re-implementation of stack accessor in terms of stackLens
+stackAccessor :: (Quasi m, HasStack m) => ExpQ -> Type -> m Exp
+stackAccessor value typ0 =
+    withStack f
+    where
+      f [] = runQ value
+      f stk = do
+        lns <- runQ $ stackLens stk
+        Just typ <- stackType
+        runQ [| view $(pure lns) $value :: $(pure typ) |]
+
+stackType :: HasStack m => m (Maybe Type)
+stackType =
+    withStack (return . f)
+    where
+      f [] = Nothing
+      f (StackElement fld _ _ : _) = Just (fType fld)
+
+-- | Return an expression of a lens for the value described by the
+-- stack.
+stackLens :: [StackElement] -> Q Exp
+stackLens [] = [| iso id id |]
+stackLens xs = mapM fieldLens xs >>= foldl1 (\ a b -> [|$b . $a|]) . map return
+
+nthLens :: Int -> Lens' [a] a
+nthLens n = lens (\ xs -> xs !! n) (\ xs x -> take (n - 1) xs ++ [x] ++ drop n xs)
+
+-- | Generate a lens to access a field, as represented by the
+-- StackElement type.
+fieldLens :: StackElement -> Q Exp
+fieldLens e@(StackElement fld con _) =
+    do lns <-
+           case fName fld of
+              Right fieldName ->
+                  -- Use the field name to build an accessor
+                  let lensName = lensNamer (nameBase fieldName) in
+                  lookupValueName lensName >>= maybe (error ("fieldLensName - missing lens: " ++ lensName)) varE
+              Left fieldPos ->
+                  -- Build a pattern expression to extract the field
+                  do cname <- lookupValueName (nameBase $ constructorName con) >>= return . fromMaybe (error $ "fieldLens: " ++ show e)
+                     f <- newName "f"
+                     let n = length $ constructorFieldTypes con
+                     as <- mapM newName (map (\ p -> "_a" ++ show p) [1..n])
+                     [| lens -- \ (Con _ _ _ x _ _) -> x
+                             $(lamE [conP cname (set (nthLens fieldPos) (varP f) (repeat wildP))] [| $(varE f) :: $(pure (fType fld)) |])
+                             -- \ x (Con a b c _ d e) -> Con a b c x d e
+                             $(lamE [conP cname (map varP as), varP f] (foldl appE (conE cname) (set (nthLens fieldPos) (varE f) (map varE as)))) |]
+       [| $(pure lns) {- :: Lens $(pure top) $(pure (fType fld)) -} |]
+
+-- | Generate lenses to access the fields of the row types.  Like
+-- Control.Lens.TH.makeLenses, but makes lenses for every field, and
+-- instead of removing the prefix '_' to form the lens name it adds
+-- the prefix "lens" and capitalizes the first letter of the field.
+-- 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' :: [Name] -> Q [Dec]
+makeLenses' typeNames =
+    execWriterT $ execStackT $ makeTypeInfo st >>= runReaderT typeGraphEdges >>= \ (g :: GraphEdges () TGV) -> (mapM doType . map (view etype) . Map.keys . simpleEdges $ g)
+    where
+      st = map ConT typeNames
+
+      doType (E (ConT name)) = qReify name >>= doInfo
+      doType _ = return ()
+      doInfo (TyConI dec@(NewtypeD _ typeName _ con _)) = doCons dec typeName [con]
+      doInfo (TyConI dec@(DataD _ typeName _ cons _)) = doCons dec typeName cons
+      doInfo _ = return ()
+      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 typeName (Named (fieldName, _, fieldType)) =
+          doFieldType typeName fieldName fieldType
+      doField _ _ = return ()
+      doFieldType typeName fieldName (ForallT _ _ typ) = doFieldType typeName fieldName typ
+      doFieldType typeName fieldName fieldType@(ConT fieldTypeName) = qReify fieldTypeName >>= doFieldInfo typeName fieldName fieldType
+      doFieldType typeName fieldName fieldType = makeLens typeName fieldName fieldType
+      doFieldInfo typeName fieldName fieldType (TyConI _fieldTypeDec) = makeLens typeName fieldName fieldType
+      doFieldInfo _ _ _ (PrimTyConI _ _ _) = return ()
+      doFieldInfo _ _ _ info = error $ "makeLenses - doFieldType: " ++ show info
+
+      makeLens typeName fieldName fieldType =
+          do let lensName = mkName (lensNamer (nameBase fieldName))
+             sig <- runQ $ sigD lensName (runQ [t|Lens' $(conT typeName) $(pure fieldType)|])
+             val <- runQ $ valD (varP lensName) (normalB (runQ [|lens $(varE fieldName) (\ s x -> $(recUpdE [|s|] [ (,) <$> pure fieldName <*> [|x|] ]))|])) []
+             return [sig, val] >>= tell
+
+-- | Given a field name, return the name to use for the corresponding lens.
+lensNamer :: String -> String
+lensNamer (n : ame) = "lens" ++ [toUpper n] ++ ame
+lensNamer "" = error "Saw the empty string as a field name"
diff --git a/Language/Haskell/TH/TypeGraph/Unsafe.hs b/Language/Haskell/TH/TypeGraph/Unsafe.hs
--- a/Language/Haskell/TH/TypeGraph/Unsafe.hs
+++ b/Language/Haskell/TH/TypeGraph/Unsafe.hs
@@ -8,15 +8,17 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Language.Haskell.TH.TypeGraph.Unsafe () where
 
-import Language.Haskell.TH (Pred, Type)
 import Language.Haskell.TH.TypeGraph.Expand (Expanded(markExpanded, runExpanded'))
+import Language.Haskell.TH (Type)
 
-instance Expanded Type Type where
-    markExpanded = id
-    runExpanded' = id
+#if __GLASGOW_HASKELL__ < 709
+import Language.Haskell.TH (Pred)
 
-#if !MIN_VERSION_template_haskell(2,10,0)
 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
@@ -1,38 +1,52 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 module Language.Haskell.TH.TypeGraph.Vertex
     ( TypeGraphVertex(..)
-    , field, syns, etype
-    , typeNames
-    , bestType
-    , typeVertex -- old
-    , fieldVertex -- old
-    , oldVertex -- old
+    , TGV(..), field, vsimple
+    , TGVSimple(..), syns, etype
+    , simpleVertex
     ) where
 
-import Control.Lens -- (makeLenses, view)
+import Control.Lens
 import Data.List as List (concatMap, intersperse)
-import Data.Set as Set (empty, insert, minView, Set, toList)
+import Data.Set as Set (insert, minView, Set, toList)
 import Language.Haskell.Exts.Syntax ()
 import Language.Haskell.TH -- (Con, Dec, nameBase, Type)
-import Language.Haskell.TH.Desugar (DsMonad)
 import Language.Haskell.TH.Instances ()
 import Language.Haskell.TH.PprLib (hcat, ptext)
 import Language.Haskell.TH.Syntax (Lift(lift))
-import Language.Haskell.TH.TypeGraph.Core (Field, unReify, unReifyName)
 import Language.Haskell.TH.TypeGraph.Expand (E(E), runExpanded)
+import Language.Haskell.TH.TypeGraph.Prelude (unReify, unReifyName)
+import Language.Haskell.TH.TypeGraph.Shape (Field)
 
 -- | For simple type graphs always set _field and _synonyms to Nothing.
-data TypeGraphVertex
-    = TypeGraphVertex
-      { _field :: Maybe (Name, Name, Either Int Name) -- ^ The record filed which contains this type
-      , _syns :: Set Name -- ^ All the type synonyms that expand to this type
+data TGV
+    = TGV
+      { _field :: Maybe Field -- ^ The record field which contains this type
+      , _vsimple :: TGVSimple
+      } deriving (Eq, Ord, Show)
+
+-- | For simple type graphs always set _field and _synonyms to Nothing.
+data TGVSimple
+    = TGVSimple
+      { _syns :: Set Name -- ^ All the type synonyms that expand to this type
       , _etype :: E Type -- ^ The fully expanded type
       } deriving (Eq, Ord, Show)
 
-instance Ppr TypeGraphVertex where
-    ppr (TypeGraphVertex {_field = fld, _syns = ns, _etype = typ}) =
+instance Ppr TGVSimple where
+    ppr (TGVSimple {_syns = ns, _etype = typ}) =
         hcat (ppr (unReify (runExpanded typ)) :
+              case (Set.toList ns) of
+                 [] -> []
+                 _ ->   [ptext " ("] ++
+                        intersperse (ptext ", ")
+                          (List.concatMap (\ n -> [ptext ("aka " ++ show (unReifyName n))]) (Set.toList ns)) ++
+                        [ptext ")"])
+
+instance Ppr TGV where
+    ppr (TGV {_field = fld, _vsimple = TGVSimple {_syns = ns, _etype = typ}}) =
+        hcat (ppr (unReify (runExpanded typ)) :
               case (fld, Set.toList ns) of
                  (Nothing, []) -> []
                  _ ->   [ptext " ("] ++
@@ -41,28 +55,31 @@
                            maybe [] (\ f -> [ppr f]) fld) ++
                         [ptext ")"])
 
-$(makeLenses ''TypeGraphVertex)
+$(makeLenses ''TGV)
+$(makeLenses ''TGVSimple)
 
--- | Return the set of 'Name' of a type's synonyms, plus the name (if
--- any) used in its data declaration.  Note that this might return the
--- empty set.
-typeNames :: TypeGraphVertex -> Set Name
-typeNames (TypeGraphVertex {_etype = E (ConT tname), _syns = s}) = Set.insert tname s
-typeNames (TypeGraphVertex {_syns = s}) = s
+simpleVertex :: TGV -> TGVSimple
+simpleVertex = _vsimple
 
-bestType :: TypeGraphVertex -> Type
-bestType (TypeGraphVertex {_etype = E (ConT name)}) = ConT name
-bestType v = maybe (let (E x) = view etype v in x) (ConT . fst) (Set.minView (view syns v))
+class TypeGraphVertex v where
+    typeNames :: v -> Set Name
+    -- ^ Return the set of 'Name' of a type's synonyms, plus the name (if
+    -- any) used in its data declaration.  Note that this might return the
+    -- empty set.
+    bestType :: v -> Type
 
-instance Lift TypeGraphVertex where
-    lift (TypeGraphVertex {_field = f, _syns = ns, _etype = t}) =
-        [|TypeGraphVertex {_field = $(lift f), _syns = $(lift ns), _etype = $(lift t)}|]
+instance TypeGraphVertex TGV where
+    typeNames = typeNames . _vsimple
+    bestType = bestType . _vsimple
 
-typeVertex :: DsMonad m => Type -> m TypeGraphVertex
-typeVertex typ = return $ TypeGraphVertex {_etype = E typ, _field = Nothing, _syns = Set.empty}
-fieldVertex :: DsMonad m => Type -> (Name, Name, Either Int Name) -> m TypeGraphVertex
-fieldVertex typ fld = return $ TypeGraphVertex {_etype = E typ, _field = Just fld, _syns = Set.empty}
+instance TypeGraphVertex TGVSimple where
+    typeNames (TGVSimple {_etype = E (ConT tname), _syns = s}) = Set.insert tname s
+    typeNames (TGVSimple {_syns = s}) = s
+    bestType (TGVSimple {_etype = E (ConT name)}) = ConT name
+    bestType v = maybe (let (E x) = view etype v in x) (ConT . fst) (Set.minView (view syns v))
 
--- Transitional
-oldVertex :: DsMonad m => (Maybe Field, Type) -> m TypeGraphVertex
-oldVertex (fld, typ) = maybe (typeVertex typ) (fieldVertex typ) fld
+instance Lift TGV where
+    lift (TGV {_field = f, _vsimple = s}) = [|TGV {_field = $(lift f), _vsimple = $(lift s)}|]
+
+instance Lift TGVSimple where
+    lift (TGVSimple {_syns = ns, _etype = t}) = [|TGVSimple {_syns = $(lift ns), _etype = $(lift t)}|]
diff --git a/test/Common.hs b/test/Common.hs
--- a/test/Common.hs
+++ b/test/Common.hs
@@ -2,6 +2,7 @@
 module Common where
 
 import Control.Applicative ((<$>))
+import Control.Lens (view)
 import Control.Monad.Reader (MonadReader, ReaderT)
 import Data.Default (Default)
 import Data.List as List (intercalate, map)
@@ -11,12 +12,13 @@
 import Data.Generics (Data, everywhere, mkT)
 import Language.Haskell.TH
 import Language.Haskell.TH.Desugar (DsMonad)
-import Language.Haskell.TH.TypeGraph.Core (Field, pprint')
+import Language.Haskell.TH.TypeGraph.Edges (GraphEdges)
 import Language.Haskell.TH.TypeGraph.Expand (E, markExpanded, runExpanded)
-import Language.Haskell.TH.TypeGraph.Graph (GraphEdges)
-import Language.Haskell.TH.TypeGraph.Info (TypeGraphInfo, typeGraphInfo)
-import Language.Haskell.TH.TypeGraph.Monad (typeGraphEdges)
-import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..))
+import Language.Haskell.TH.TypeGraph.Info (TypeInfo)
+import Language.Haskell.TH.TypeGraph.Edges (typeGraphEdges)
+import Language.Haskell.TH.TypeGraph.Prelude (pprint')
+import Language.Haskell.TH.TypeGraph.Shape (Field)
+import Language.Haskell.TH.TypeGraph.Vertex (etype, syns, TGV, TGVSimple, TypeGraphVertex, vsimple)
 
 import Language.Haskell.TH.Syntax (Lift(lift))
 
@@ -44,36 +46,33 @@
 pprintType :: E Type -> String
 pprintType = pprint' . unReify . runExpanded
 
-pprintVertex :: TypeGraphVertex -> String
+pprintVertex :: Ppr v => v -> String
 pprintVertex = pprint'
 
 pprintPred :: E Pred -> String
 pprintPred = pprint' . unReify . runExpanded
 
-edgesToStrings :: GraphEdges label TypeGraphVertex -> [(String, [String])]
+edgesToStrings :: (TypeGraphVertex v, Ppr v) => GraphEdges label v -> [(String, [String])]
 edgesToStrings mp = List.map (\ (t, (_, s)) -> (pprintVertex t, map pprintVertex (Set.toList s))) (Map.toList mp)
 
-typeGraphInfo' :: DsMonad m => [Type] -> m TypeGraphInfo
-typeGraphInfo' = typeGraphInfo
-
-typeGraphEdges' :: forall m. (DsMonad m, MonadReader TypeGraphInfo m) => m (GraphEdges () TypeGraphVertex)
+typeGraphEdges' :: forall m. (DsMonad m, MonadReader TypeInfo 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 TypeGraphInfo m) =>
-                  m (Map TypeGraphVertex (Set Name))
+typeSynonymMap :: forall m. (DsMonad m, MonadReader TypeInfo m) =>
+                  m (Map TGV (Set Name))
 typeSynonymMap =
      (Map.filter (not . Set.null) .
       Map.fromList .
-      List.map (\node -> (node, _syns node)) .
-      Map.keys) <$> (typeGraphEdges :: m (GraphEdges () TypeGraphVertex))
+      List.map (\node -> (node, view (vsimple . syns) node)) .
+      Map.keys) <$> (typeGraphEdges :: m (GraphEdges () TGV))
 
 -- | Like 'typeSynonymMap', but with all field information removed.
-typeSynonymMapSimple :: forall m. (DsMonad m, MonadReader TypeGraphInfo m) =>
+typeSynonymMapSimple :: forall m. (DsMonad m, MonadReader TypeInfo m) =>
                         m (Map (E Type) (Set Name))
 typeSynonymMapSimple =
     simplify <$> typeSynonymMap
     where
-      simplify :: Map TypeGraphVertex (Set Name) -> Map (E Type) (Set Name)
-      simplify mp = Map.fromListWith Set.union (List.map (\ (k, a) -> (_etype k, a)) (Map.toList mp))
+      simplify :: Map TGV (Set Name) -> Map (E Type) (Set Name)
+      simplify mp = Map.fromListWith Set.union (List.map (\ (k, a) -> (view (vsimple . etype) k, a)) (Map.toList mp))
diff --git a/test/TypeGraph.hs b/test/TypeGraph.hs
--- a/test/TypeGraph.hs
+++ b/test/TypeGraph.hs
@@ -13,13 +13,11 @@
 import Data.Map as Map (Map, fromList, keys)
 import Data.Set as Set (fromList, singleton)
 import Language.Haskell.TH
-import Language.Haskell.TH.TypeGraph.Core (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)
-import Language.Haskell.TH.TypeGraph.Graph (dissolveM)
-import Language.Haskell.TH.TypeGraph.Info (synonyms)
-import Language.Haskell.TH.TypeGraph.Monad (vertex, simpleEdges)
-import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..))
+import Language.Haskell.TH.TypeGraph.Free (freeTypeVars, typeArity)
+import Language.Haskell.TH.TypeGraph.Info (makeTypeInfo, synonyms, typeVertex')
+import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..), TGV(..), TGVSimple(..), etype, field, vsimple, syns)
 import Language.Haskell.TH.Desugar (withLocalDeclarations)
 import Language.Haskell.TH.Instances ()
 import Language.Haskell.TH.Syntax
@@ -33,54 +31,54 @@
 tests = do
 
   it "records a type synonym 1" $ do
-     $([t|String|] >>= \string -> typeGraphInfo' [string] >>= lift . view synonyms) `shouldBe` (Map.fromList [(E (AppT ListT (ConT ''Char)), Set.singleton ''String)])
+     $([t|String|] >>= \string -> makeTypeInfo [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 -> typeGraphInfo' [string] >>= runReaderT (expandType string >>= vertex Nothing) >>= lift) `shouldBe` (TypeGraphVertex Nothing (singleton ''String) (E (AppT ListT (ConT ''Char))))
+     $([t|String|] >>= \string -> makeTypeInfo [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 -> typeGraphInfo' [typ] >>= lift . pprint) `shouldBe` typeGraphInfoOfType
+    $(runQ [t|Type|] >>= \typ -> makeTypeInfo [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 ->
-                                typeGraphInfo' [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=
+                                makeTypeInfo [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 [] $
                                 runQ [t|Type|] >>= \typ ->
-                                typeGraphInfo' [typ] >>= runReaderT typeGraphEdges' >>=
+                                makeTypeInfo [typ] >>= runReaderT typeGraphEdges' >>=
                                 runQ . lift . edgesToStrings)) typeEdges
         `shouldBe` noDifferences
 
   it "can find the subtypesOfType" $ do
      setDifferences (Set.fromList $(withLocalDeclarations [] $
                                   runQ [t|Type|] >>= \typ ->
-                                  typeGraphInfo' [typ] >>= runReaderT typeGraphEdges' >>=
+                                  makeTypeInfo [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 [] $
                                 runQ [t|Type|] >>= \typ ->
-                                typeGraphInfo' [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=
-                                dissolveM (\ v -> (/= 0) <$> (typeArity . runExpanded . _etype) v) >>=
+                                makeTypeInfo [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=
+                                dissolveM (\ v -> (/= 0) <$> (typeArity . runExpanded . view etype) v) >>=
                                 runQ . lift . edgesToStrings)) arity0TypeEdges
         `shouldBe` noDifferences
 #if 0
   it "can find the edges of the simple subtype graph of Dec (decEdges)" $ do
      setDifferences (Set.fromList $(withLocalDeclarations [] $
                                 runQ [t|Dec|] >>= \typ ->
-                                typeGraphInfo' [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=
+                                makeTypeInfo [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=
                                 runQ . lift . edgesToStrings)) decEdges
         `shouldBe` noDifferences
 
   it "can find the edges of the arity 0 subtype graph of Dec (arity0DecEdges)" $ do
      setDifferences (Set.fromList $(withLocalDeclarations [] $
                                 runQ [t|Dec|] >>= \typ ->
-                                typeGraphInfo' [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=
+                                makeTypeInfo [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=
                                 dissolveM (\ v -> (/= 0) <$> (typeArity . runExpanded . _etype) v) >>=
                                 runQ . lift . edgesToStrings)) arity0DecEdges
         `shouldBe` noDifferences
@@ -88,14 +86,14 @@
   it "can find the subtypesOfDec" $ do
      setDifferences (Set.fromList $(withLocalDeclarations [] $
                                 runQ [t|Dec|] >>= \typ ->
-                                typeGraphInfo' [typ] >>= runReaderT typeGraphVertices >>=
+                                makeTypeInfo [typ] >>= runReaderT typeGraphVertices >>=
                                 runQ . lift . List.map pprint . Set.toList . Set.map simpleVertex)) subtypesOfDec
         `shouldBe` noDifferences
 
   it "can find the arity0SubtypesOfDec" $ do
      setDifferences (Set.fromList $(withLocalDeclarations [] $
                                 runQ [t|Dec|] >>= \typ ->
-                                typeGraphInfo' [typ] >>= runReaderT typeGraphVertices >>=
+                                makeTypeInfo [typ] >>= runReaderT typeGraphVertices >>=
                                 return . Set.toList . Set.map simpleVertex >>=
                                 filterM (\ t -> typeArity (runExpanded (_etype t)) >>= \ a -> return (a == 0)) >>=
                                 runQ . lift . List.map pprint)) arity0SubtypesOfDec
@@ -104,13 +102,13 @@
   it "can find the simpleSubtypesOfDec" $ do
      setDifferences (Set.fromList $(withLocalDeclarations [] $
                                 runQ [t|Dec|] >>= \typ ->
-                                typeGraphInfo' [typ] >>= runReaderT typeGraphVertices >>=
+                                makeTypeInfo [typ] >>= runReaderT typeGraphVertices >>=
                                 runQ . lift . List.map pprint . Set.toList . Set.map simpleVertex)) simpleSubtypesOfDec
         `shouldBe` noDifferences
 
   it "can find the type synonyms in Dec (decTypeSynonyms)" $ do
      $(withLocalDeclarations [] $
-       runQ [t|Dec|] >>= \typ -> typeGraphInfo' [typ] >>= runReaderT (typeSynonymMapSimple >>= runQ . lift)) `shouldBe` decTypeSynonyms
+       runQ [t|Dec|] >>= \typ -> makeTypeInfo [typ] >>= runReaderT (typeSynonymMapSimple >>= runQ . lift)) `shouldBe` decTypeSynonyms
 #endif
 
   it "can find the free type variable names in: Map k a" $ do
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.Core (typeArity)
+import Language.Haskell.TH.TypeGraph.Edges (typeGraphEdges)
 import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType, markExpanded)
-import Language.Haskell.TH.TypeGraph.Monad (typeGraphEdges)
+import Language.Haskell.TH.TypeGraph.Free (typeArity)
 import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..))
 import Language.Haskell.TH.Desugar (withLocalDeclarations)
 import Language.Haskell.TH.Instances ()
@@ -20,10 +20,10 @@
 
 import Common
 
-typeGraphInfoOfType =
+typeInfoOfType =
     unlines
 #if MIN_VERSION_template_haskell(2,10,0)
-    [ "TypeGraphInfo:",
+    [ "TypeInfo:",
       "  typeSet:",
       "    [GHC.Types.Char]",
       "    [Language.Haskell.TH.Syntax.Pred]",
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.18
+version:            0.21
 cabal-version:      >= 1.10
 build-type:         Simple
 license:            BSD3
@@ -18,24 +18,27 @@
 
 library
   build-depends:
-    base >= 4.2 && < 5,
+    base >= 4.8 && < 5,
+    base-compat,
     containers,
     data-default,
     haskell-src-exts,
     lens,
     mtl,
+    set-extra,
     syb,
-    template-haskell >= 2.9,
+    template-haskell >= 2.10,
     th-desugar,
     th-orphans >= 0.10.0
   ghc-options:      -Wall
-  exposed-modules:  Language.Haskell.TH.TypeGraph
-                    Language.Haskell.TH.TypeGraph.Core
+  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.Monad
+                    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
   default-language: Haskell2010