packages feed

th-typegraph 0.28 → 0.31

raw patch · 10 files changed

+159/−152 lines, 10 filesdep ~mtl-unleashed

Dependency ranges changed: mtl-unleashed

Files

Language/Haskell/TH/TypeGraph/Edges.hs view
@@ -33,11 +33,13 @@ #endif import Control.Lens -- (makeLenses, view) import Control.Monad (filterM)-import Control.Monad.Readers (ask, MonadReaders)-import Control.Monad.States (MonadStates, modify, execStateT, StateT)+import Control.Monad.Readers (askPoly, MonadReaders)+import Control.Monad.State (execStateT, StateT)+import Control.Monad.States (MonadStates, modifyPoly) import Control.Monad.Trans (lift) import Data.Foldable-import Data.List as List (filter, intercalate, map)+import Data.Function (on)+import Data.List as List (filter, intercalate, map, sortBy) 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)@@ -61,13 +63,13 @@ -- types. typeGraphEdges :: forall m. (DsMonad m, Functor m, MonadReaders TypeInfo m, MonadStates ExpandMap m) => m (GraphEdges TGV) typeGraphEdges = do-  execStateT (view typeSet <$> ask >>= mapM_ (\t -> lift (expandType t) >>= doType)) (mempty :: GraphEdges TGV)+  execStateT (view typeSet <$> askPoly >>= mapM_ (\t -> lift (expandType t) >>= doType)) (mempty :: GraphEdges TGV)     where       doType typ = do         vs <- allVertices Nothing typ         mapM_ node vs         case typ of-          E (ConT tname) -> ask >>= \(x :: TypeInfo) -> doInfo vs (view infoMap x ! tname)+          E (ConT tname) -> askPoly >>= \(x :: TypeInfo) -> doInfo vs (view infoMap x ! tname)           E (AppT typ1 typ2) -> do             v1 <- typeVertex' (E typ1)             v2 <- typeVertex' (E typ2)@@ -106,21 +108,21 @@        node :: TGV -> StateT (GraphEdges TGV) m ()       -- node v = pass (return ((), (Map.alter (Just . maybe (def, Set.empty) id) v)))-      node v = modify (Map.alter (Just . maybe (Set.empty) id) v :: Map TGV (Set TGV) -> Map TGV (Set TGV))+      node v = modifyPoly (Map.alter (Just . maybe (Set.empty) id) v :: Map TGV (Set TGV) -> Map TGV (Set TGV))        edge :: TGV -> TGV -> StateT (GraphEdges TGV) m ()-      edge v1 v2 = node v2 >> modify f+      edge v1 v2 = node v2 >> modifyPoly f           where f :: GraphEdges TGV -> GraphEdges TGV                 f = Map.alter g v1                 g :: (Maybe (Set TGV) -> Maybe (Set TGV))                 g = Just . maybe (singleton v2) (Set.insert v2) -instance Ppr key => Ppr (GraphEdges key) where+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)))-                       (Map.toList x))+                       (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
@@ -29,7 +29,7 @@     , expandClassP     ) where -import Control.Monad.States (MonadStates(get), modify)+import Control.Monad.States (MonadStates(getPoly), modifyPoly) import Data.Map as Map (Map, lookup, insert) import Language.Haskell.Exts.Syntax () import Language.Haskell.TH@@ -53,11 +53,11 @@ -- | Apply the th-desugar expand function to a 'Type' and mark it as expanded. expandType :: (DsMonad m, MonadStates ExpandMap m)  => Type -> m (E Type) expandType typ = do-  get >>= maybe expandType' return . Map.lookup typ+  getPoly >>= maybe expandType' return . Map.lookup typ     where       expandType' =           do e <- E <$> DS.typeToTH <$> (DS.dsType typ >>= DS.expand)-             modify (Map.insert typ e)+             modifyPoly (Map.insert typ e)              return e  -- | Apply the th-desugar expand function to a 'Pred' and mark it as expanded.
Language/Haskell/TH/TypeGraph/Lens.hs view
@@ -19,8 +19,7 @@  import Control.Category ((.)) import Control.Lens as Lens (makeLensesFor, view)-import Control.Monad.Readers (MonadReaders)-import qualified Control.Monad.Readers as Readers (view)+import Control.Monad.Readers (MonadReaders, viewPoly) import Control.Monad.States (MonadStates) import Control.Monad.Writer (execWriterT, tell) import Data.Map as Map (keys)@@ -31,7 +30,7 @@ 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, StackElement)+import Language.Haskell.TH.TypeGraph.Stack (lensNamer) import Language.Haskell.TH.TypeGraph.TypeGraph (edges, TypeGraph) import Language.Haskell.TH.TypeGraph.Vertex (etype) import Prelude hiding ((.))@@ -42,10 +41,10 @@ -- 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 [StackElement] m, MonadReaders TypeGraph m) =>+makeTypeGraphLenses :: forall m. (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m) =>                        m [Dec] makeTypeGraphLenses =-    execWriterT $ Readers.view edges >>= mapM doType . map (view etype) . Map.keys . simpleEdges+    execWriterT $ viewPoly edges >>= mapM doType . map (view etype) . Map.keys . simpleEdges     where       doType (E (ConT tname)) = qReify tname >>= doInfo       doType _ = return ()
Language/Haskell/TH/TypeGraph/Prelude.hs view
@@ -16,9 +16,10 @@     , adjacent'     , reachable'     , L(L)+    , friendlyNames     ) where -import Control.Lens+import Control.Lens hiding (cons) import Data.Generics (Data, everywhere, mkT) import Data.Graph as Graph import Data.List (intersperse)@@ -27,7 +28,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), Quasi(qReify))+import Language.Haskell.TH.Syntax (Lift(lift), Name(Name), NameFlavour(NameS), Quasi(qReify))  instance Ppr () where     ppr () = ptext "()"@@ -127,3 +128,14 @@     where       reachableVerts = Graph.reachable g v       v = fromMaybe (error "Language.Haskell.TH.TypeGraph.Prelude.reachable") (kf k)++-- | Make a template haskell value more human reader friendly.  The+-- result almost certainly won't be compilable.  That's ok, though,+-- because the input is usually uncompilable - it imports hidden modules,+-- uses infix operators in invalid positions, puts module qualifiers in+-- places where they are not allowed, and maybe other things.+friendlyNames :: Data a => a -> a+friendlyNames =+    everywhere (mkT friendlyName)+    where+      friendlyName (Name x _) = Name x NameS -- Remove all module qualifiers
Language/Haskell/TH/TypeGraph/Stack.hs view
@@ -13,7 +13,10 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall #-} module Language.Haskell.TH.TypeGraph.Stack-    ( StackElement(..)+    ( TypeStack(..)+    , topType+    , typeStack+    , StackElement(..)     , prettyStack     , foldField       -- * Stack+instance map monad@@ -30,8 +33,10 @@  import Control.Applicative import Control.Category ((.))-import Control.Lens as Lens (iso, Lens', lens, set, view)-import Control.Monad.Readers (MonadReaders(ask, local), ReaderT, runReaderT)+import Control.Lens as Lens -- (iso, Lens', lens, set, view, (%=), (.~))+import Control.Monad.Reader (ReaderT, runReaderT)+import Control.Monad.Readers (MonadReaders(askPoly, localPoly))+--import Control.Monad.States (over') import Data.Char (toUpper) import Data.Generics (Data, Typeable) import Data.Maybe (fromMaybe)@@ -49,19 +54,30 @@ -- we only need the field names. data StackElement = StackElement FieldType Con Dec deriving (Eq, Show, Data, Typeable) -type HasStack = MonadReaders [StackElement]+-- | A stack describes a path from a top type down through fields of+-- its component types.+data TypeStack+    = TypeStack+      { _topType :: Type+      , _typeStack :: [StackElement]+      } deriving (Eq, Show, Data, Typeable) -withStack :: (Monad m, MonadReaders [StackElement] m) => ([StackElement] -> m a) -> m a-withStack f = ask >>= f+$(makeLenses ''TypeStack) -push :: MonadReaders [StackElement] m => FieldType -> Con -> Dec -> m a -> m a-push fld con dec = local (\stk -> StackElement fld con dec : stk)+type HasStack = MonadReaders TypeStack -traceIndented :: MonadReaders [StackElement] m => String -> m ()-traceIndented s = withStack $ \stk -> trace (replicate (length stk) ' ' ++ s) (return ())+withStack :: (Monad m, MonadReaders TypeStack m) => (TypeStack -> m a) -> m a+withStack f = askPoly >>= f -prettyStack :: [StackElement] -> String-prettyStack = prettyStack' . reverse+-- | push an element onto the TypeStack in m+push :: MonadReaders TypeStack m => FieldType -> Con -> Dec -> m a -> m a+push fld con dec action = localPoly (\(stk :: TypeStack) -> set typeStack (StackElement fld con dec : view typeStack stk) stk) action++traceIndented :: MonadReaders TypeStack m => String -> m ()+traceIndented s = withStack $ \stk -> trace (replicate (length (view typeStack stk)) ' ' ++ s) (return ())++prettyStack :: TypeStack -> String+prettyStack stk = prettyType (view topType stk) ++ " → " ++ prettyStack' (reverse (view typeStack stk))     where       prettyStack' :: [StackElement] -> String       prettyStack' [] = "(empty)"@@ -79,38 +95,44 @@       prettyType typ = "(" ++ show typ ++ ")"  -- | Push the stack and process the field.-foldField :: MonadReaders [StackElement] m => (FieldType -> m r) -> Dec -> Con -> FieldType -> m r+foldField :: MonadReaders TypeStack 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+type StackT m = ReaderT TypeStack m -execStackT :: Monad m => StackT m a -> m a-execStackT action = runReaderT action []+execStackT :: Monad m => StackT m a -> Type -> m a+execStackT action type0 = runReaderT action (TypeStack {_topType = type0, _typeStack = []})  -- | Return a lambda function that turns a value of Type typ0 into the -- type implied by the stack elements.-stackAccessor :: (Quasi m, MonadReaders [StackElement] m) => m Exp+stackAccessor :: (Quasi m, MonadReaders TypeStack m) => m Exp stackAccessor =     withStack f     where-      f [] = runQ [|id|]+      -- It works without this case, but this way the code is a little+      -- neater.  FIXME: Actually, we should have a stackView function+      -- that only builds the getter, we are just throwing away the+      -- lens's setter here.+      f stk | null (view typeStack stk) = runQ [|id|]       f stk = do         lns <- runQ $ stackLens stk         Just typ <- stackType         runQ [| \x -> (Lens.view $(pure lns) x) :: $(pure typ) |] -stackType :: MonadReaders [StackElement] m => m (Maybe Type)+stackType :: MonadReaders TypeStack m => m (Maybe Type) stackType =-    withStack (return . f)+    withStack (return . f . view typeStack)     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+stackLens :: TypeStack -> Q Exp+stackLens stk =+    case view typeStack stk of+      [] -> [| iso id id |]+      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)
Language/Haskell/TH/TypeGraph/TypeGraph.hs view
@@ -13,8 +13,10 @@  module Language.Haskell.TH.TypeGraph.TypeGraph     ( TypeGraph, typeInfo, edges, graph, gsimple, stack+    , makeTypeGraph     , graphFromMap +    -- * TypeGraph queries     , allLensKeys     , allPathKeys     , allPathStarts@@ -24,9 +26,7 @@     , goalReachableSimple     , goalReachableSimple' -    , makeTypeGraph     , VertexStatus(..)-    , typeGraphEdges'     , adjacent     , typeGraphVertex     , typeGraphVertexOfField@@ -39,25 +39,25 @@ import Control.Applicative #endif import Control.Lens-import Control.Monad (when)+-- import Control.Monad (when) import qualified Control.Monad.Reader as MTL (ask, ReaderT, runReaderT)-import Control.Monad.Readers (MonadReaders(ask, local))-import Control.Monad.States (execStateT, MonadStates(get), modify, StateT)+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.Graph hiding (edges) import Data.List as List (map)-import Data.Map as Map (alter, fromList, fromListWith, Map, update)+import Data.Map as Map (fromList, fromListWith, Map) import qualified Data.Map as Map (toList) import Data.Maybe (fromJust, mapMaybe)-import Data.Set.Extra as Set (empty, fromList, insert, map, member, Set, singleton, toList, union, unions)+import Data.Set.Extra as Set (empty, fromList, map, Set, singleton, toList, union, unions) import Data.Traversable as Traversable import Language.Haskell.Exts.Syntax () import Language.Haskell.TH import Language.Haskell.TH.Desugar (DsMonad) import Language.Haskell.TH.Instances ()-import Language.Haskell.TH.PprLib (ptext)+import Language.Haskell.TH.PprLib (ptext, vcat) import Language.Haskell.TH.Syntax (Quasi(..)) import Language.Haskell.TH.TypeGraph.Edges (GraphEdges, simpleEdges) import Language.Haskell.TH.TypeGraph.Expand (E(E), ExpandMap, expandType)@@ -70,6 +70,18 @@ instance Ppr Vertex where     ppr n = ptext ("V" ++ show n) +-- | 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+             , _gsimple = graphFromMap (simpleEdges es)+             , _stack = []+             }+ -- | Build a graph from the result of typeGraphEdges, each edge goes -- from a type to one of the types it contains.  Thus, each edge -- represents a primitive lens, and each path in the graph is a@@ -94,31 +106,34 @@ $(makeLenses ''TypeGraph)  instance (Monad m, MonadReaders [StackElement] m) => MonadReaders [StackElement] (MTL.ReaderT TypeGraph m) where-    ask = lift ask-    local f action = MTL.ask >>= MTL.runReaderT (local f (lift action))+    askPoly = lift askPoly+    localPoly f action = MTL.ask >>= MTL.runReaderT (localPoly f (lift action)) -allPathStarts :: forall m. (DsMonad m, MonadStates (Map Type (E Type)) m, MonadReaders TypeGraph m) => m (Set TGV)+instance Ppr TypeGraph where+    ppr tg = vcat [ptext "TypeGraph: ", ppr (view edges tg)]++allPathStarts :: forall m. (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m) => m (Set TGV) allPathStarts = do   -- (g, vf, kf) <- graphFromMap <$> view edges-  (g, vf, kf) <- ask >>= return . view graph-  kernel <- ask >>= return . view typeInfo >>= \ti -> MTL.runReaderT (Traversable.mapM expandType (view startTypes ti) >>= Traversable.mapM typeVertex') ti+  (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   let keep = Set.fromList $ concatMap (reachable g) (mapMaybe kf kernel)       keep' = Set.map (view _2) . Set.map vf $ keep   return keep'  view' :: MonadReaders s m => Getting b s b -> m b-view' lns = view lns <$> ask+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 (Map Type (E Type)) m, MonadReaders TypeGraph m) => m (Map TGVSimple (Set TGV))+allLensKeys ::  (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m) => m (Map TGVSimple (Set TGV)) allLensKeys = do   g <- view' graph-  gs <- view' gsimple+  -- gs <- view' gsimple   allPathStarts >>= return . Map.fromListWith Set.union . List.map (\x -> (view vsimple x, Set.fromList (adjacent' g x))) . Set.toList  -- | Paths go between simple types.-allPathKeys :: (DsMonad m, MonadStates (Map Type (E Type)) m, MonadReaders TypeGraph m) => m (Map TGVSimple (Set TGVSimple))+allPathKeys :: (DsMonad m, MonadStates ExpandMap m, MonadReaders TypeGraph m) => m (Map TGVSimple (Set TGVSimple)) allPathKeys = do   gs <- view' gsimple   allPathStarts >>= return . Map.fromList . List.map (\x -> (x, Set.fromList (reachable' gs x))) . Set.toList . Set.map (view vsimple)@@ -143,11 +158,13 @@ goalReachableFull :: (Functor m, DsMonad m, MonadReaders TypeGraph m) => TGV -> TGV -> m Bool goalReachableFull gkey key0 = isReachable gkey key0 <$> view' graph +-- | Can we reach the goal type in the simplified graph? goalReachableSimple :: (Functor m, DsMonad m, MonadReaders TypeGraph m) => TGVSimple -> TGVSimple -> m Bool goalReachableSimple gkey key0 = isReachable gkey key0 <$> view' gsimple +-- | Version of goalReachableSimple that first simplifies its argument nodes goalReachableSimple' :: (Functor m, DsMonad m, MonadReaders TypeGraph m) => TGV -> TGV -> m Bool-goalReachableSimple' gkey key0 = isReachable (view vsimple gkey) (view vsimple key0) <$> view' gsimple+goalReachableSimple' gkey key0 = goalReachableSimple (view vsimple gkey) (view vsimple key0)  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)@@ -157,14 +174,15 @@ typeGraphVertex :: (MonadReaders TypeGraph m, MonadStates ExpandMap m, DsMonad m) => Type -> m TGV typeGraphVertex typ = do         typ' <- expandType typ-        ask >>= MTL.runReaderT (typeVertex' typ') . view typeInfo+        askPoly >>= MTL.runReaderT (typeVertex' typ') . view typeInfo         -- magnify typeInfo $ vertex Nothing typ'  -- | Return the TGV associated with a particular type and field.-typeGraphVertexOfField :: (MonadReaders TypeGraph m, MonadStates (Map Type (E Type)) m, DsMonad m) => (Name, Name, Either Int Name) -> Type -> m TGV+typeGraphVertexOfField :: (MonadReaders TypeGraph m, MonadStates ExpandMap m, DsMonad m) =>+                          (Name, Name, Either Int Name) -> Type -> m TGV typeGraphVertexOfField fld typ = do         typ' <- expandType typ-        ask >>= MTL.runReaderT (fieldVertex fld typ') . view typeInfo+        askPoly >>= MTL.runReaderT (fieldVertex fld typ') . view typeInfo         -- magnify typeInfo $ vertex (Just fld) typ'  -- type TypeGraphEdges typ = Map typ (Set typ)@@ -181,51 +199,10 @@ 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, MonadReaders TypeGraph m, MonadStates (Set TGV) m, MonadStates (Map Type (E Type)) m) =>-       (TGV -> m (Set TGV))-           -- ^ This function is applied to every expanded type before-           -- use, and the result is used instead.  If it returns-           -- NoVertex, no vertices or edges are added to the graph.-           -- If it returns Sink no outgoing edges are added.  The-           -- current use case Substitute is to see if there is an-           -- instance of class @View a b@ where @a@ is the type-           -- passed to @doType@, and replace it with @b@, and use the-           -- lens returned by @View's@ method to convert between @a@-           -- and @b@ (i.e. to implement the edge in the type graph.)-    -> [Type]-    -> m (GraphEdges TGV)-typeGraphEdges' augment types = do-  execStateT (mapM_ (\typ -> lift (typeGraphVertex typ) >>= doNode) types) (mempty :: GraphEdges TGV)-    where-      doNode v = do-        (s :: Set TGV) <- lift get-        when (not (member v s)) $-             do lift $ modify (Set.insert v)-                doNode' v-      doNode' :: TGV -> StateT (GraphEdges TGV) m ()-      doNode' typ = do-        addNode typ-        vs <- lift $ augment typ-        mapM_ (addEdge typ) (Set.toList vs)-        mapM_ doNode (Set.toList vs)--      addNode :: TGV -> StateT (GraphEdges TGV) m ()-      addNode a = modify (Map.alter (maybe (Just Set.empty) Just) a :: Map TGV (Set TGV) -> Map TGV (Set TGV))--      addEdge :: TGV -> TGV -> StateT (GraphEdges TGV) m ()-      addEdge a b = modify $ Map.update (\s -> Just (Set.insert b s)) a- -- | Return the set of adjacent vertices according to the default type -- graph - i.e. the one determined only by the type definitions, not -- by any additional hinting function.-adjacent :: forall m. (MonadReaders TypeGraph m, DsMonad m, MonadStates (Map Type (E Type)) m) => TGV -> m (Set TGV)+adjacent :: forall m. (MonadReaders TypeGraph m, DsMonad m, MonadStates ExpandMap m) => TGV -> m (Set TGV) adjacent typ =     case view (vsimple . etype) typ of       E (ForallT _ _ typ') -> typeGraphVertex typ' >>= adjacent@@ -254,15 +231,3 @@        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 :: MonadReaders TypeInfo m => (GraphEdges TGV) -> m TypeGraph-makeTypeGraph es = do-  ti <- ask-  return $ TypeGraph-             { _typeInfo = ti-             , _edges = es-             , _graph = graphFromMap es-             , _gsimple = graphFromMap (simpleEdges es)-             , _stack = []-             }
Language/Haskell/TH/TypeGraph/TypeInfo.hs view
@@ -26,9 +26,10 @@ import Data.Monoid (mempty) #endif import Control.Lens -- (makeLenses, view)-import Control.Monad.Readers (ask, MonadReaders)+import Control.Monad.Readers (askPoly, MonadReaders) import Control.Monad.Trans as Monad-import Control.Monad.States (execStateT, MonadStates(get, put), StateT)+import Control.Monad.State (execStateT, StateT)+import Control.Monad.States (MonadStates(getPoly, putPoly)) import Data.Foldable as Foldable (mapM_) import Data.List as List (intercalate, map) import Data.Map as Map (findWithDefault, insert, insertWith, Map, toList)@@ -55,7 +56,7 @@       -- 'Maybe' and the 'Int' in @Maybe Int@.       , _infoMap :: Map Name Info       -- ^ The Info record of all known named types-      , _expanded :: Map Type (E Type)+      , _expanded :: ExpandMap       -- ^ Map of the expansion of all encountered types       , _synonyms :: Map (E Type) (Set Name)       -- ^ The types with all type synonyms replaced with their expansions.@@ -76,8 +77,8 @@ $(makeLenses ''TypeInfo)  instance Monad m => MonadStates ExpandMap (StateT TypeInfo m) where-    get = use expanded-    put x = expanded .= x+    getPoly = use expanded+    putPoly x = expanded .= x  instance Lift TypeInfo where     lift (TypeInfo {_startTypes = st, _typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f}) =@@ -174,7 +175,7 @@ -- field containing that type. fieldVertices :: MonadReaders TypeInfo m => TGVSimple -> m (Set TGV) fieldVertices v = do-  fm <- view fields <$> ask+  fm <- view fields <$> askPoly   let fs = Map.findWithDefault Set.empty (view etype v) fm   return $ Set.map (\fld' -> TGV {_vsimple = v, _field = Just fld'}) fs @@ -185,7 +186,7 @@ -- | Build a non-field vertex typeVertex :: MonadReaders TypeInfo m => E Type -> m TGVSimple typeVertex etyp = do-  sm <- view synonyms <$> ask+  sm <- view synonyms <$> askPoly   return $ TGVSimple {_syns = Map.findWithDefault Set.empty etyp sm, _etype = etyp}  typeVertex' :: MonadReaders TypeInfo m => E Type -> m TGV
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))+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)@@ -56,12 +56,12 @@ edgesToStrings :: (TypeGraphVertex v, Ppr v) => GraphEdges v -> [(String, [String])] edgesToStrings mp = List.map (\ (t, s) -> (pprintVertex t, map pprintVertex (Set.toList s))) (Map.toList mp) -typeGraphEdges' :: forall m. (DsMonad m, MonadReaders TypeInfo m, MonadStates (Map Type (E Type)) m) => m (GraphEdges TGV)+typeGraphEdges' :: forall m. (DsMonad m, MonadReaders TypeInfo m, MonadStates ExpandMap 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, MonadReaders TypeInfo m, MonadStates (Map Type (E Type)) m) =>+typeSynonymMap :: forall m. (DsMonad m, MonadReaders TypeInfo m, MonadStates ExpandMap m) =>                   m (Map TGV (Set Name)) typeSynonymMap =      (Map.filter (not . Set.null) .@@ -70,7 +70,7 @@       Map.keys) <$> (typeGraphEdges :: m (GraphEdges TGV))  -- | Like 'typeSynonymMap', but with all field information removed.-typeSynonymMapSimple :: forall m. (DsMonad m, MonadReaders TypeInfo m, MonadStates (Map Type (E Type)) m) =>+typeSynonymMapSimple :: forall m. (DsMonad m, MonadReaders TypeInfo m, MonadStates ExpandMap m) =>                         m (Map (E Type) (Set Name)) typeSynonymMapSimple =     simplify <$> typeSynonymMap
test/TypeGraph.hs view
@@ -9,14 +9,15 @@ #endif import Control.Lens import Control.Monad.Reader (runReaderT)-import Control.Monad.State (evalStateT)+import Control.Monad.State (evalStateT, StateT)+import Control.Monad.States (MonadStates(..)) 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 (expandType, E(E, unE))+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)@@ -37,7 +38,7 @@    it "records a type synonym 2" $ do      $([t|String|] >>= \string ->-       flip evalStateT (Map.empty :: Map Type (E Type))+       flip evalStateT (Map.empty :: ExpandMap)                 (makeTypeInfo (const $ return mempty) [string] >>=                  runReaderT (expandType string >>= typeVertex')) >>= lift)           `shouldBe` (TGV {_field = Nothing, _vsimple = TGVSimple {_syns = singleton ''String, _etype = E (AppT ListT (ConT ''Char))}})@@ -46,28 +47,28 @@     $(runQ [t|Type|] >>= \typ -> makeTypeInfo (const $ return mempty) [typ] >>= lift . pprint) `shouldBe` typeInfoOfType    it "can find the edges of the (simplified) subtype graph of Type (typeEdges)" $ do-     setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: Map Type (E Type)) $+     setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: ExpandMap) $                                       runQ [t|Type|] >>= \typ ->                                       makeTypeInfo (const $ return mempty) [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=                                       runQ . lift . edgesToStrings)) simpleTypeEdges         `shouldBe` noDifferences    it "can find the edges of the (unsimplified) subtype graph of Type (typeEdges)" $ do-     setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: Map Type (E Type)) $+     setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: ExpandMap) $                                 runQ [t|Type|] >>= \typ ->                                 makeTypeInfo (const $ return mempty) [typ] >>= runReaderT typeGraphEdges' >>=                                 runQ . lift . edgesToStrings)) typeEdges         `shouldBe` noDifferences    it "can find the subtypesOfType" $ do-     setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: Map Type (E Type)) $+     setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: ExpandMap) $                                   runQ [t|Type|] >>= \typ ->                                   makeTypeInfo (const $ return mempty) [typ] >>= runReaderT typeGraphEdges' >>=                                   runQ . lift . List.map pprintVertex . Map.keys)) subtypesOfType         `shouldBe` noDifferences    it "can find the edges of the arity 0 subtype graph of Type (arity0TypeEdges)" $ do-     setDifferences (Set.fromList $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: Map Type (E Type)) $+     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) >>=
th-typegraph.cabal view
@@ -1,5 +1,5 @@ name:               th-typegraph-version:            0.28+version:            0.31 cabal-version:      >= 1.10 build-type:         Simple license:            BSD3@@ -16,22 +16,14 @@                     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   hs-source-dirs: .-  build-depends:-    base >= 4.8 && < 5,-    base-compat,-    containers,-    data-default,-    haskell-src-exts,-    lens,-    mtl,-    mtl-unleashed >= 0.2.1,-    set-extra,-    syb,-    template-haskell >= 2.10,-    th-desugar,-    th-orphans >= 0.10.0   ghc-options: -Wall -O2   exposed-modules:     Language.Haskell.TH.TypeGraph.Arity@@ -45,14 +37,27 @@     Language.Haskell.TH.TypeGraph.TypeGraph     Language.Haskell.TH.TypeGraph.TypeInfo     Language.Haskell.TH.TypeGraph.Vertex-  default-language: Haskell2010+  build-depends:+    base >= 4.8 && < 5,+    base-compat,+    containers,+    data-default,+    haskell-src-exts,+    lens,+    mtl,+    mtl-unleashed >= 0.5,+    set-extra,+    syb,+    template-haskell >= 2.10,+    th-desugar,+    th-orphans >= 0.10.0  test-suite th-typegraph-tests   type:             exitcode-stdio-1.0   hs-source-dirs:   test   main-is:          Tests.hs   build-depends:    array, base, bytestring, containers, data-default, deepseq, ghc-prim,-                    hspec, hspec-core, lens, mtl, mtl-unleashed, syb, template-haskell, text,+                    hspec, hspec-core, lens, mtl, mtl-unleashed >= 0.5, syb, template-haskell, text,                     th-typegraph, th-desugar, th-orphans, th-reify-many   default-language: Haskell2010