packages feed

th-typegraph 0.31 → 0.32

raw patch · 11 files changed

+173/−124 lines, 11 files

Files

Language/Haskell/TH/TypeGraph/Arity.hs view
@@ -14,20 +14,21 @@ -- 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+typeArity t0 = typeArity' t0     where+      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+      typeArity' typ = error $ "typeArity (" ++ pprint' t0 ++ ") - unexpected type: " ++ show typ       infoArity (TyConI dec) = decArity dec       infoArity (PrimTyConI _ _ _) = return 0       infoArity (FamilyI dec _) = decArity dec-      infoArity info = error $ "typeArity - unexpected: " ++ pprint' info+      infoArity info = error $ "typeArity (" ++ pprint' t0 ++ ")- unexpected info: " ++ show 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 (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+      decArity dec = error $ "typeArity (" ++ pprint' t0 ++ ")- unexpected dec: " ++ show dec
Language/Haskell/TH/TypeGraph/Edges.hs view
@@ -38,17 +38,14 @@ import Control.Monad.States (MonadStates, modifyPoly) import Control.Monad.Trans (lift) import Data.Foldable-import Data.Function (on)-import Data.List as List (filter, intercalate, map, sortBy)+import Data.List as List (filter, 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.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), ExpandMap, expandType)-import Language.Haskell.TH.TypeGraph.Prelude (pprint') import Language.Haskell.TH.TypeGraph.TypeInfo (TypeInfo, infoMap, typeSet, allVertices, fieldVertex, typeVertex') import Language.Haskell.TH.TypeGraph.Vertex (TGV, TGVSimple, vsimple) import Language.Haskell.TH.Desugar as DS (DsMonad)@@ -116,13 +113,6 @@                 f = Map.alter g v1                 g :: (Maybe (Set TGV) -> Maybe (Set TGV))                 g = Just . maybe (singleton v2) (Set.insert v2)--instance (Ppr key, Show key) => Ppr (GraphEdges 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)))-                       (sortBy (compare `on` show) (Map.toList x)))  -- | Isolate and remove matching nodes cut :: (Eq a, Ord a) => (a -> Bool) -> GraphEdges a -> GraphEdges a
Language/Haskell/TH/TypeGraph/Expand.hs view
@@ -13,7 +13,7 @@ -- provided in "Language.Haskell.TH.Context.Unsafe", for when less -- type safety is required. -{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -22,14 +22,16 @@ {-# LANGUAGE TemplateHaskell #-}  module Language.Haskell.TH.TypeGraph.Expand-    ( E(E, unE)+    ( E(E, _unE), unE     , ExpandMap     , expandType     , expandPred     , expandClassP     ) where +import Control.Lens (makeLenses) import Control.Monad.States (MonadStates(getPoly), modifyPoly)+import Data.Data (Data) import Data.Map as Map (Map, lookup, insert) import Language.Haskell.Exts.Syntax () import Language.Haskell.TH@@ -39,13 +41,15 @@ import Prelude hiding (pred)  -- | A concrete type used to mark type which have been expanded-newtype E a = E {unE :: a} deriving (Eq, Ord, Show)+newtype E a = E {_unE :: a} deriving (Eq, Ord, Show, Data)  instance Ppr a => Ppr (E a) where     ppr (E x) = ppr x  instance Lift (E Type) where-    lift etype = [|E $(lift (unE etype))|]+    lift etype = [|E $(lift (_unE etype))|]++$(makeLenses ''E)  -- | The state type used to memoize expansions. type ExpandMap = Map Type (E Type)
Language/Haskell/TH/TypeGraph/Lens.hs view
@@ -19,7 +19,7 @@  import Control.Category ((.)) import Control.Lens as Lens (makeLensesFor, view)-import Control.Monad.Readers (MonadReaders, viewPoly)+import Control.Monad.Readers (MonadReaders) import Control.Monad.States (MonadStates) import Control.Monad.Writer (execWriterT, tell) import Data.Map as Map (keys)@@ -28,10 +28,10 @@ import Language.Haskell.TH.Desugar (DsMonad) import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax hiding (lift)-import Language.Haskell.TH.TypeGraph.Edges (simpleEdges) import Language.Haskell.TH.TypeGraph.Expand (E(E), ExpandMap) import Language.Haskell.TH.TypeGraph.Stack (lensNamer)-import Language.Haskell.TH.TypeGraph.TypeGraph (edges, TypeGraph)+import Language.Haskell.TH.TypeGraph.TypeGraph (allLensKeys, TypeGraph)+import Language.Haskell.TH.TypeGraph.TypeInfo (TypeInfo) import Language.Haskell.TH.TypeGraph.Vertex (etype) import Prelude hiding ((.)) @@ -41,10 +41,9 @@ -- the prefix "lens" and capitalizes the first letter of the field. -- The only reason for this function is backwards compatibility, -- makeLensesFor should be used instead.-makeTypeGraphLenses :: forall m. (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m) =>-                       m [Dec]+makeTypeGraphLenses :: forall m. (DsMonad m, MonadReaders TypeInfo m, MonadReaders TypeGraph m, MonadStates ExpandMap m) => m [Dec] makeTypeGraphLenses =-    execWriterT $ viewPoly edges >>= mapM doType . map (view etype) . Map.keys . simpleEdges+    allLensKeys >>= execWriterT . mapM doType . map (view etype) . Map.keys     where       doType (E (ConT tname)) = qReify tname >>= doInfo       doType _ = return ()
Language/Haskell/TH/TypeGraph/Prelude.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE TupleSections #-} module Language.Haskell.TH.TypeGraph.Prelude     ( pprint'+    , OverTypes(overTypes)     , unlifted     , constructorName     , declarationName@@ -20,6 +21,7 @@     ) where  import Control.Lens hiding (cons)+import Control.Monad (foldM) import Data.Generics (Data, everywhere, mkT) import Data.Graph as Graph import Data.List (intersperse)@@ -28,7 +30,7 @@ import Data.Set as Set (fromList, Set, toList) import Language.Haskell.TH import Language.Haskell.TH.PprLib (ptext, hcat)-import Language.Haskell.TH.Syntax (Lift(lift), Name(Name), NameFlavour(NameS), Quasi(qReify))+import Language.Haskell.TH.Syntax (Lift(lift), Name(Name), NameFlavour(NameS), Quasi(qReify), StrictType, VarStrictType)  instance Ppr () where     ppr () = ptext "()"@@ -39,38 +41,51 @@     ppr (L l) = hcat ([ptext "["] ++ intersperse (ptext ", ") (map ppr l) ++ [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+-- white space (newlines, tabs, etc.) converted to a single space, and+-- all the module qualifiers removed from the names.+pprint' :: (Ppr a, Data a) => a -> [Char]+pprint' typ = unwords $ words $ pprint $ friendlyNames $ 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+-- | Perform a fold over the Type and Info values embedded in t+class OverTypes t where+    overTypes :: Quasi m => (a -> Either Info Type -> m a) -> a -> t -> m a -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 OverTypes Dec where+    overTypes f a (DataD _ _ _ cons _) = foldM (overTypes f) a cons+    overTypes f a (NewtypeD _ _ _ con _) = overTypes f a con+    overTypes f a (TySynD _ _ typ) = overTypes f a typ+    overTypes _ a _ = return a -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 OverTypes StrictType where+    overTypes f a (_, t) = overTypes f a t -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 OverTypes VarStrictType where+    overTypes f a (_, _, t) = overTypes f a t -instance IsUnlifted Info where-    unlifted (PrimTyConI _ _ _) = return True-    unlifted _ = return False -- traversal stops here+instance OverTypes Con where+    overTypes f a (ForallC _ _ con) = overTypes f a con+    overTypes f a (NormalC _ ts) = foldM (overTypes f) a ts+    overTypes f a (RecC _ ts) = foldM (overTypes f) a ts+    overTypes f a (InfixC t1 _ t2) = overTypes f a t1 >>= flip (overTypes f) t2++instance OverTypes Type where+    overTypes f a t@(AppT t1 t2) = f a (Right t) >>= flip (overTypes f) t1 >>= flip (overTypes f) t2+    overTypes f a (ConT name) = qReify name >>= overTypes f a+    overTypes f a t@(ForallT _ _ typ) = f a (Right t) >>= flip (overTypes f) typ+    overTypes f a t = f a (Right t)++instance OverTypes Info where+    overTypes f a x = f a (Left x)++-- | 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.+unlifted :: (OverTypes t, Quasi m) => t -> m Bool+unlifted x = overTypes f False x+    where+      f _ (Left (PrimTyConI _ _ _)) = return True+      f r _ = return r  constructorName :: Con -> Name constructorName (ForallC _ _ con) = constructorName con
Language/Haskell/TH/TypeGraph/Stack.hs view
@@ -34,9 +34,9 @@ import Control.Applicative import Control.Category ((.)) import Control.Lens as Lens -- (iso, Lens', lens, set, view, (%=), (.~))-import Control.Monad.Reader (ReaderT, runReaderT)+import Control.Monad.Reader (ask, ReaderT, runReaderT) import Control.Monad.Readers (MonadReaders(askPoly, localPoly))---import Control.Monad.States (over')+import Control.Monad.Trans (lift) import Data.Char (toUpper) import Data.Generics (Data, Typeable) import Data.Maybe (fromMaybe)@@ -47,6 +47,7 @@ import Language.Haskell.TH.Syntax hiding (lift) import Language.Haskell.TH.TypeGraph.Prelude (constructorName) import Language.Haskell.TH.TypeGraph.Shape (FieldType(..), fName, fType, constructorFieldTypes)+import Language.Haskell.TH.TypeGraph.TypeInfo (TypeInfo) import Prelude hiding ((.))  -- | The information required to extact a field value from a value.@@ -68,6 +69,10 @@  withStack :: (Monad m, MonadReaders TypeStack m) => (TypeStack -> m a) -> m a withStack f = askPoly >>= f++instance MonadReaders TypeInfo m => MonadReaders TypeInfo (ReaderT TypeStack m) where+    askPoly = lift askPoly+    localPoly f action = ask >>= runReaderT (localPoly f (lift action))  -- | push an element onto the TypeStack in m push :: MonadReaders TypeStack m => FieldType -> Con -> Dec -> m a -> m a
Language/Haskell/TH/TypeGraph/TypeGraph.hs view
@@ -12,14 +12,15 @@ {-# LANGUAGE TypeFamilies #-}  module Language.Haskell.TH.TypeGraph.TypeGraph-    ( TypeGraph, typeInfo, edges, graph, gsimple, stack+    ( TypeGraph, graph, gsimple, stack     , makeTypeGraph     , graphFromMap      -- * TypeGraph queries-    , allLensKeys-    , allPathKeys+    , allPathNodes     , allPathStarts+    , lensKeys, allLensKeys+    , pathKeys, allPathKeys     , reachableFrom     , reachableFromSimple     , goalReachableFull@@ -39,17 +40,17 @@ import Control.Applicative #endif import Control.Lens--- import Control.Monad (when)+import Control.Monad (foldM) import qualified Control.Monad.Reader as MTL (ask, ReaderT, runReaderT) import Control.Monad.Readers (MonadReaders(askPoly, localPoly)) import Control.Monad.States (MonadStates) import Control.Monad.Trans (lift) import Data.Default (Default(def))-import Data.Foldable as Foldable+import Data.Foldable as Fold import Data.Graph hiding (edges) import Data.List as List (map)-import Data.Map as Map (fromList, fromListWith, Map)-import qualified Data.Map as Map (toList)+import Data.Map.Strict as Map (insertWith, Map)+import qualified Data.Map.Strict as Map (toList) import Data.Maybe (fromJust, mapMaybe) import Data.Set.Extra as Set (empty, fromList, map, Set, singleton, toList, union, unions) import Data.Traversable as Traversable@@ -64,20 +65,21 @@ import Language.Haskell.TH.TypeGraph.Prelude (adjacent', reachable') import Language.Haskell.TH.TypeGraph.TypeInfo (startTypes, TypeInfo, typeVertex', fieldVertex) import Language.Haskell.TH.TypeGraph.Stack (StackElement)-import Language.Haskell.TH.TypeGraph.Vertex (TGV, TGVSimple, vsimple, TypeGraphVertex, etype)+import Language.Haskell.TH.TypeGraph.Vertex (TGV, TGVSimple, tgv, vsimple, TypeGraphVertex, etype) import Prelude hiding (any, concat, concatMap, elem, exp, foldr, mapM_, null, or) -instance Ppr Vertex where-    ppr n = ptext ("V" ++ show n)+data TypeGraph+    = TypeGraph+      { _graph :: (Graph, Vertex -> ((), TGV, [TGV]), TGV -> Maybe Vertex)+      , _gsimple :: (Graph, Vertex -> ((), TGVSimple, [TGVSimple]), TGVSimple -> Maybe Vertex)+      , _stack :: [StackElement]+      }  -- | Build a TypeGraph given a set of edges and the TypeInfo environment makeTypeGraph :: MonadReaders TypeInfo m => (GraphEdges TGV) -> m TypeGraph makeTypeGraph es = do-  ti <- askPoly   return $ TypeGraph-             { _typeInfo = ti-             , _edges = es-             , _graph = graphFromMap es+             { _graph = graphFromMap es              , _gsimple = graphFromMap (simpleEdges es)              , _stack = []              }@@ -92,16 +94,7 @@     graphFromEdges triples     where       triples :: [((), key, [key])]-      triples = List.map (\ (k, ks) -> ((), k, Foldable.toList ks)) $ Map.toList mp--data TypeGraph-    = TypeGraph-      { _typeInfo :: TypeInfo-      , _edges :: GraphEdges TGV-      , _graph :: (Graph, Vertex -> ((), TGV, [TGV]), TGV -> Maybe Vertex)-      , _gsimple :: (Graph, Vertex -> ((), TGVSimple, [TGVSimple]), TGVSimple -> Maybe Vertex)-      , _stack :: [StackElement]-      }+      triples = List.map (\ (k, ks) -> ((), k, Fold.toList ks)) $ Map.toList mp  $(makeLenses ''TypeGraph) @@ -109,35 +102,64 @@     askPoly = lift askPoly     localPoly f action = MTL.ask >>= MTL.runReaderT (localPoly f (lift action)) -instance Ppr TypeGraph where-    ppr tg = vcat [ptext "TypeGraph: ", ppr (view edges tg)]+instance MonadReaders TypeInfo m => MonadReaders TypeInfo (MTL.ReaderT TypeGraph m) where+    askPoly = lift askPoly+    localPoly f action = MTL.ask >>= MTL.runReaderT (localPoly f (lift action)) -allPathStarts :: forall m. (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m) => m (Set TGV)-allPathStarts = do-  -- (g, vf, kf) <- graphFromMap <$> view edges+instance Ppr Vertex where+    ppr n = ptext ("V" ++ show n)++instance Ppr (Graph, Vertex -> ((), TGV, [TGV]), TGV -> Maybe Vertex) where+    ppr (g, vf, _) = vcat (List.map (ppr . vf) (vertices g))++instance Ppr (Graph, Vertex -> ((), TGVSimple, [TGVSimple]), TGVSimple -> Maybe Vertex) where+    ppr (g, vf, _) = vcat (List.map (ppr . vf) (vertices g))++-- | All the nodes in the TGV (unsimplified) graph, where each field+-- of a record is a distinct node.+allPathNodes :: forall m. (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) => m (Set TGV)+allPathNodes = do   (g, vf, kf) <- askPoly >>= return . view graph-  kernel <- askPoly >>= return . view typeInfo >>= \ti -> MTL.runReaderT (Traversable.mapM expandType (view startTypes ti) >>= Traversable.mapM typeVertex') ti+  kernel <- askPoly >>= \ti -> MTL.runReaderT (Traversable.mapM expandType (view startTypes ti) >>= Traversable.mapM typeVertex') ti   let keep = Set.fromList $ concatMap (reachable g) (mapMaybe kf kernel)       keep' = Set.map (view _2) . Set.map vf $ keep   return keep' +-- | All the nodes in the TGVSimple graph, where each field representa+-- a different type.+allPathStarts :: forall m. (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) => m (Set TGVSimple)+allPathStarts = Set.map (view vsimple) <$> allPathNodes+ view' :: MonadReaders s m => Getting b s b -> m b view' lns = view lns <$> askPoly --- | Lenses represent steps in a path, but the start point is a type--- vertex and the endpoint is a field vertex.-allLensKeys ::  (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m) => m (Map TGVSimple (Set TGV))+-- | Each lens represents a single step in a path.  The start point is+-- a simplified vertex and the endpoint is an unsimplified vertex.+allLensKeys :: (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) => m (Map TGVSimple (Set TGV)) allLensKeys = do+  starts <- Set.toList <$> allPathStarts+  foldM (\mp s -> lensKeys s >>= return . Fold.foldr (Map.insertWith Set.union s . Set.singleton) mp) mempty starts++-- | Return the nodes adjacent to x in the lens graph.+lensKeys :: (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) => TGVSimple -> m (Set TGV)+lensKeys x = do   g <- view' graph-  -- gs <- view' gsimple-  allPathStarts >>= return . Map.fromListWith Set.union . List.map (\x -> (view vsimple x, Set.fromList (adjacent' g x))) . Set.toList+  return $ Set.fromList $ adjacent' g (tgv x)  -- | Paths go between simple types.-allPathKeys :: (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m) => m (Map TGVSimple (Set TGVSimple))+allPathKeys :: (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) => m (Map TGVSimple (Set TGVSimple)) allPathKeys = do+  starts <- Set.toList <$> allPathStarts+  foldM (\mp s -> pathKeys s >>= return . Fold.foldr (Map.insertWith Set.union s . Set.singleton) mp) mempty starts++-- | Return the nodes reachable from x in the path graph.+pathKeys :: (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m, MonadReaders TypeInfo m) => TGVSimple -> m (Set TGVSimple)+pathKeys x = do   gs <- view' gsimple-  allPathStarts >>= return . Map.fromList . List.map (\x -> (x, Set.fromList (reachable' gs x))) . Set.toList . Set.map (view vsimple)+  return $ Set.fromList $ reachable' gs x +  -- allPathStarts >>= return . Map.fromList . List.map (\x -> (x, Set.fromList (reachable' gs x))) . Set.toList . Set.map (view vsimple)+ reachableFrom :: forall m. (DsMonad m, MonadReaders TypeGraph m) => TGV -> m (Set TGV) reachableFrom v = do   -- (g, vf, kf) <- graphFromMap <$> view edges@@ -171,18 +193,18 @@  -- | Return the TGV associated with a particular type, -- with no field specified.-typeGraphVertex :: (MonadReaders TypeGraph m, MonadStates ExpandMap m, DsMonad m) => Type -> m TGV+typeGraphVertex :: ({-MonadReaders TypeGraph m,-} MonadReaders TypeInfo m, MonadStates ExpandMap m, DsMonad m) => Type -> m TGV typeGraphVertex typ = do         typ' <- expandType typ-        askPoly >>= MTL.runReaderT (typeVertex' typ') . view typeInfo+        askPoly >>= \(ti :: TypeInfo) -> MTL.runReaderT (typeVertex' typ') ti         -- magnify typeInfo $ vertex Nothing typ'  -- | Return the TGV associated with a particular type and field.-typeGraphVertexOfField :: (MonadReaders TypeGraph m, MonadStates ExpandMap m, DsMonad m) =>+typeGraphVertexOfField :: ({-MonadReaders TypeGraph m,-} MonadReaders TypeInfo m, MonadStates ExpandMap m, DsMonad m) =>                           (Name, Name, Either Int Name) -> Type -> m TGV typeGraphVertexOfField fld typ = do         typ' <- expandType typ-        askPoly >>= MTL.runReaderT (fieldVertex fld typ') . view typeInfo+        askPoly >>= \(ti :: TypeInfo) -> MTL.runReaderT (fieldVertex fld typ') ti         -- magnify typeInfo $ vertex (Just fld) typ'  -- type TypeGraphEdges typ = Map typ (Set typ)@@ -202,7 +224,7 @@ -- | 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. (MonadReaders TypeGraph m, DsMonad m, MonadStates ExpandMap m) => TGV -> m (Set TGV)+adjacent :: forall m. ({-MonadReaders TypeGraph m,-} MonadReaders TypeInfo m, DsMonad m, MonadStates ExpandMap m) => TGV -> m (Set TGV) adjacent typ =     case view (vsimple . etype) typ of       E (ForallT _ _ typ') -> typeGraphVertex typ' >>= adjacent
Language/Haskell/TH/TypeGraph/Vertex.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -5,17 +6,20 @@     ( TypeGraphVertex(..)     , TGV(..), field, vsimple     , TGVSimple(..), syns, etype+    , tgv     ) where  import Control.Lens+import Data.Data (Data) import Data.List as List (concatMap, intersperse)+import Data.Map as Map (Map, 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.Instances ()-import Language.Haskell.TH.PprLib (hcat, ptext)+import Language.Haskell.TH.PprLib (hang, hcat, ptext, text, vcat) import Language.Haskell.TH.Syntax (Lift(lift))-import Language.Haskell.TH.TypeGraph.Expand (E(E, unE))+import Language.Haskell.TH.TypeGraph.Expand (E(E), unE) import Language.Haskell.TH.TypeGraph.Prelude (unReify, unReifyName) import Language.Haskell.TH.TypeGraph.Shape (Field) @@ -26,21 +30,24 @@     = TGV       { _field :: Maybe Field -- ^ The record field which contains this type       , _vsimple :: TGVSimple-      } deriving (Eq, Ord, Show)+      } deriving (Eq, Ord, Show, Data)  -- | For simple type graphs where no parent field information is required. 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)+      } deriving (Eq, Ord, Show, Data) +tgv :: TGVSimple -> TGV+tgv v = TGV { _field = Nothing, _vsimple = v}+ $(makeLenses ''TGV) $(makeLenses ''TGVSimple)  instance Ppr TGVSimple where     ppr (TGVSimple {_syns = ns, _etype = typ}) =-        hcat (ppr (unReify (unE typ)) :+        hcat (ppr (unReify (view unE typ)) :               case (Set.toList ns) of                  [] -> []                  _ ->   [ptext " ("] ++@@ -50,7 +57,7 @@  instance Ppr TGV where     ppr (TGV {_field = fld, _vsimple = TGVSimple {_syns = ns, _etype = typ}}) =-        hcat (ppr (unReify (unE typ)) :+        hcat (ppr (unReify (view unE typ)) :               case (fld, Set.toList ns) of                  (Nothing, []) -> []                  _ ->   [ptext " ("] ++@@ -58,6 +65,18 @@                           (List.concatMap (\ n -> [ptext ("aka " ++ show (unReifyName n))]) (Set.toList ns) ++                            maybe [] (\ f -> [ppr f]) fld) ++                         [ptext ")"])++instance Ppr ((), TGV, [TGV]) where+    ppr ((), v, vs) = vcat [hcat [ppr v, text ":"], hang (text "  ") 2 (vcat (map ppr vs))]++instance Ppr ((), TGVSimple, [TGVSimple]) where+    ppr ((), v, vs) = vcat [hcat [ppr v, text ":"], hang (text "  ") 2 (vcat (map ppr vs))]++instance Ppr (Map TGV (Set TGV)) where+    ppr mp = ppr (map (\(v, vs) -> ((), v, Set.toList vs)) (Map.toList mp))++instance Ppr (Map TGVSimple (Set TGVSimple)) where+    ppr mp = ppr (map (\(v, vs) -> ((), v, Set.toList vs)) (Map.toList mp))  instance Lift TGV where     lift (TGV {_field = f, _vsimple = s}) = [|TGV {_field = $(lift f), _vsimple = $(lift s)}|]
test/Common.hs view
@@ -14,7 +14,7 @@ import Language.Haskell.TH import Language.Haskell.TH.Desugar (DsMonad) import Language.Haskell.TH.TypeGraph.Edges (GraphEdges)-import Language.Haskell.TH.TypeGraph.Expand (E(unE), ExpandMap)+import Language.Haskell.TH.TypeGraph.Expand (E, unE, ExpandMap) import Language.Haskell.TH.TypeGraph.Edges (typeGraphEdges) import Language.Haskell.TH.TypeGraph.Prelude (pprint') import Language.Haskell.TH.TypeGraph.Shape (Field)@@ -45,15 +45,15 @@ pprintDec = pprint' . unReify  pprintType :: E Type -> String-pprintType = pprint' . unReify . unE+pprintType = pprint' . unReify . view unE -pprintVertex :: Ppr v => v -> String+pprintVertex :: (Ppr v, Data v) => v -> String pprintVertex = pprint'  pprintPred :: E Pred -> String-pprintPred = pprint' . unReify . unE+pprintPred = pprint' . unReify . view unE -edgesToStrings :: (TypeGraphVertex v, Ppr v) => GraphEdges v -> [(String, [String])]+edgesToStrings :: (TypeGraphVertex v, Ppr v, Data v) => GraphEdges v -> [(String, [String])] edgesToStrings mp = List.map (\ (t, s) -> (pprintVertex t, map pprintVertex (Set.toList s))) (Map.toList mp)  typeGraphEdges' :: forall m. (DsMonad m, MonadReaders TypeInfo m, MonadStates ExpandMap m) => m (GraphEdges TGV)
test/TypeGraph.hs view
@@ -9,15 +9,14 @@ #endif import Control.Lens import Control.Monad.Reader (runReaderT)-import Control.Monad.State (evalStateT, StateT)-import Control.Monad.States (MonadStates(..))+import Control.Monad.State (evalStateT) import Data.List as List (map) import Data.Map as Map (Map, empty, fromList, keys) import Data.Set as Set (fromList, singleton) import Language.Haskell.TH import Language.Haskell.TH.TypeGraph.Arity (typeArity) import Language.Haskell.TH.TypeGraph.Edges (dissolveM, simpleEdges)-import Language.Haskell.TH.TypeGraph.Expand (E(E, unE), ExpandMap, expandType)+import Language.Haskell.TH.TypeGraph.Expand (E(E), unE, ExpandMap, expandType) import Language.Haskell.TH.TypeGraph.Free (freeTypeVars) import Language.Haskell.TH.TypeGraph.TypeInfo (makeTypeInfo, synonyms, typeVertex') import Language.Haskell.TH.TypeGraph.Vertex (TGV(..), TGVSimple(..), etype)@@ -71,7 +70,7 @@      setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: ExpandMap) $                                 runQ [t|Type|] >>= \typ ->                                 makeTypeInfo (const $ return mempty) [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=-                                dissolveM (\ v -> (/= 0) <$> (typeArity . unE . view etype) v) >>=+                                dissolveM (\ v -> (/= 0) <$> (typeArity . view unE . view etype) v) >>=                                 runQ . lift . edgesToStrings)) arity0TypeEdges         `shouldBe` noDifferences #if 0
th-typegraph.cabal view
@@ -1,5 +1,5 @@ name:               th-typegraph-version:            0.31+version:            0.32 cabal-version:      >= 1.10 build-type:         Simple license:            BSD3@@ -15,11 +15,6 @@                     the subtype relation: Char is a subtype of Maybe Char, Int is                     a subtype of (Int, Double), and so on. extra-source-files: test/Common.hs test/Tests.hs test/TypeGraph.hs test/Values.hs--flag local-mtl-unleashed-  Description: flag-  Default: False-  Manual: True  library   default-language: Haskell2010