packages feed

th-typegraph 0.24 → 0.25

raw patch · 10 files changed

+103/−176 lines, 10 filesdep +mtl-unleashed

Dependencies added: mtl-unleashed

Files

Language/Haskell/TH/TypeGraph/Arity.hs view
@@ -11,7 +11,8 @@  -- | 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'.+-- 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
Language/Haskell/TH/TypeGraph/Edges.hs view
@@ -33,8 +33,8 @@ #endif import Control.Lens -- (makeLenses, view) import Control.Monad (filterM)-import Control.Monad.Reader (MonadReader)-import Control.Monad.State (execStateT, modify, StateT)+import Control.Monad.Readers (ask, MonadReaders)+import Control.Monad.States (MonadStates, modify, execStateT, StateT) import Control.Monad.Trans (lift) import Data.Foldable import Data.List as List (filter, intercalate, map)@@ -45,8 +45,7 @@ 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.HasState (HasState)+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)@@ -60,16 +59,15 @@ -- fields, build and return the GraphEdges relation on TypeGraphVertex. -- This is not a recursive function, it stops when it reaches the field -- types.-typeGraphEdges :: forall m. (DsMonad m, Functor m, MonadReader TypeInfo m, HasState (Map Type (E Type)) m) => m (GraphEdges TGV)+typeGraphEdges :: forall m. (DsMonad m, Functor m, MonadReaders TypeInfo m, MonadStates ExpandMap m) => m (GraphEdges TGV) typeGraphEdges = do-  execStateT (view typeSet >>= mapM_ (\t -> lift (expandType t) >>= doType)) mempty+  execStateT (view typeSet <$> ask >>= mapM_ (\t -> lift (expandType t) >>= doType)) (mempty :: GraphEdges TGV)     where-      doType :: E Type -> StateT (GraphEdges 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 (ConT tname) -> ask >>= \(x :: TypeInfo) -> doInfo vs (view infoMap x ! tname)           E (AppT typ1 typ2) -> do             v1 <- typeVertex' (E typ1)             v2 <- typeVertex' (E typ2)@@ -108,7 +106,7 @@        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)+      node v = modify (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
Language/Haskell/TH/TypeGraph/Expand.hs view
@@ -29,14 +29,13 @@     , expandClassP     ) where --- import Data.Function.Memoize (deriveMemoizable, memoize)+import Control.Monad.States (MonadStates(get), modify) import Data.Map as Map (Map, lookup, insert) import Language.Haskell.Exts.Syntax () import Language.Haskell.TH import Language.Haskell.TH.Desugar as DS (DsMonad, dsType, expand, typeToTH) import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax -- (Lift(lift))-import Language.Haskell.TH.TypeGraph.HasState (HasState(getState, modifyState)) import Prelude hiding (pred)  -- | A concrete type used to mark type which have been expanded@@ -52,20 +51,20 @@ type ExpandMap = Map Type (E Type)  -- | Apply the th-desugar expand function to a 'Type' and mark it as expanded.-expandType :: (DsMonad m, HasState ExpandMap m)  => Type -> m (E Type)+expandType :: (DsMonad m, MonadStates ExpandMap m)  => Type -> m (E Type) expandType typ = do-  getState >>= maybe expandType' return . Map.lookup typ+  get >>= maybe expandType' return . Map.lookup typ     where       expandType' =           do e <- E <$> DS.typeToTH <$> (DS.dsType typ >>= DS.expand)-             modifyState (Map.insert typ e)+             modify (Map.insert typ e)              return e  -- | Apply the th-desugar expand function to a 'Pred' and mark it as expanded. -- Note that the definition of 'Pred' changed in template-haskell-2.10.0.0.-expandPred :: (DsMonad m, HasState ExpandMap m)  => Type -> m (E Type)+expandPred :: (DsMonad m, MonadStates ExpandMap m)  => Type -> m (E Type) expandPred = expandType  -- | Expand a list of 'Type' and build an expanded 'ClassP' 'Pred'.-expandClassP :: forall m. (DsMonad m, HasState ExpandMap m)  => Name -> [Type] -> m (E Type)+expandClassP :: forall m. (DsMonad m, MonadStates ExpandMap m)  => Name -> [Type] -> m (E Type) expandClassP className typeParameters = (expandType $ foldl AppT (ConT className) typeParameters) :: m (E Type)
Language/Haskell/TH/TypeGraph/Free.hs view
@@ -16,11 +16,11 @@  data St     = St { _result :: Set Name-         , _stack :: Set Name+         , _visited :: Set Name          } deriving Show  st0 :: St-st0 = St {_result = empty, _stack = empty}+st0 = St {_result = empty, _visited = empty}  $(makeLenses ''St) @@ -66,11 +66,11 @@ go_app :: (Quasi m, MonadState St m) => [Type] -> Type -> m () go_app params (AppT t1 t2) = go_app (t2 : params) t1 go_app params (ConT n) = do-    stk <- use stack+    stk <- use visited     case Set.member n stk of       True -> return ()       False -> do-        stack %= Set.insert n+        visited %= Set.insert n         qReify n >>= go_info (reverse params) go_app params typ = mapM_ ftv (typ : params) go_info :: (Quasi m, MonadState St m) => [Type] -> Info -> m ()
− Language/Haskell/TH/TypeGraph/HasState.hs 
@@ -1,45 +0,0 @@--- | MonadState without the function dependency @m -> s@.-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Language.Haskell.TH.TypeGraph.HasState-    ( HasState(getState, modifyState)-    ) where--import Control.Monad.Reader (ReaderT)-import Control.Monad.RWS (RWST)-import Control.Monad.State (StateT, get, modify)-import Control.Monad.Trans (lift)-import Control.Monad.Writer (WriterT)---- | This class allows you to access bits of the State by type,--- without knowing exactly what the overall state type is.  For--- example:------   typeGraphEdges :: (DsMonad m,---                      MonadReader TypeGraph m,---                      HasState (Set TGV) m,---                      HasState (Map Type (E Type)) m) => ...------ This will work as long as the two HasState instances exist for--- whatever the actual State type is.  It still can't reach down--- into nested StateT monads, you may need to use lift for that.--class HasState s m where-    getState :: m s-    modifyState :: (s -> s) -> m ()--instance Monad m => HasState s (StateT s m) where-    getState = get-    modifyState = modify--instance (Monad m, Monoid w) => HasState s (RWST r w s m) where-    getState = get-    modifyState = modify--instance (Monad m, HasState s m) => HasState s (ReaderT r m) where-    getState = lift getState-    modifyState f = lift $ modifyState f--instance (Monad m, Monoid w, HasState s m) => HasState s (WriterT w m) where-    getState = lift getState-    modifyState f = lift $ modifyState f
Language/Haskell/TH/TypeGraph/Stack.hs view
@@ -3,6 +3,7 @@ -- type mechanism, and is unaware of View instances and other things -- that modify the type graph.  Lets see how it adapts. {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -12,14 +13,15 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall #-} module Language.Haskell.TH.TypeGraph.Stack-    ( HasStack(push, withStack)-    , Wrapper(Wrapper), unwrap-    , StackElement(..)+    ( StackElement(..)     , prettyStack     , foldField       -- * Stack+instance map monad+    , HasStack     , StackT     , execStackT+    , withStack+    , push       -- * Stack operations     , stackAccessor     , makeLenses'@@ -28,17 +30,15 @@  import Control.Applicative import Control.Category ((.))-import Control.Lens (iso, Lens', lens, makeLenses, set, view)-import Control.Monad.Reader (ReaderT, runReaderT, ask, local)-import Control.Monad.RWS (RWST)-import Control.Monad.State (StateT, evalStateT, get)+import Control.Lens (iso, Lens', lens, set, view)+import Control.Monad.Readers (MonadReaders(ask, local), ReaderT, runReaderT)+import Control.Monad.States (MonadStates) import Control.Monad.Trans (lift)-import Control.Monad.Writer (WriterT, runWriterT, execWriterT, tell)+import Control.Monad.Writer (WriterT, 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 Data.Set (Set) import Debug.Trace (trace) import Language.Haskell.Exts.Syntax ()@@ -48,7 +48,6 @@ import Language.Haskell.TH.Syntax hiding (lift) import Language.Haskell.TH.TypeGraph.Edges (GraphEdges, simpleEdges, typeGraphEdges) import Language.Haskell.TH.TypeGraph.Expand (E(E), ExpandMap)-import Language.Haskell.TH.TypeGraph.HasState (HasState) import Language.Haskell.TH.TypeGraph.Prelude (constructorName) import Language.Haskell.TH.TypeGraph.Shape (FieldType(..), fName, fType, constructorFieldTypes) import Language.Haskell.TH.TypeGraph.TypeInfo (makeTypeInfo)@@ -60,44 +59,15 @@ -- 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---- We can't write @HasStack (ReaderT a m)@ because it overlaps with--- @HasStack (ReaderT [StackElement] m)@.  However, we can write--- @HasStack (ReaderT (Wrapper a) m@.-instance HasStack m => HasStack (ReaderT (Wrapper a) m) where-    withStack f = lift (withStack return) >>= f-    push fld con dec action =-        do r <- ask-           a <- lift $ push fld con dec (runReaderT action r)-           return a--newtype Wrapper a = Wrapper {_unwrap :: a}+type HasStack = MonadReaders [StackElement] -$(makeLenses ''Wrapper)+withStack :: (Monad m, MonadReaders [StackElement] m) => ([StackElement] -> m a) -> m a+withStack f = ask >>= f -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+push :: MonadReaders [StackElement] m => FieldType -> Con -> Dec -> m a -> m a+push fld con dec = local (\stk -> StackElement fld con dec : stk) -traceIndented :: HasStack m => String -> m ()+traceIndented :: MonadReaders [StackElement] m => String -> m () traceIndented s = withStack $ \stk -> trace (replicate (length stk) ' ' ++ s) (return ())  prettyStack :: [StackElement] -> String@@ -119,7 +89,7 @@       prettyType typ = "(" ++ show typ ++ ")"  -- | Push the stack and process the field.-foldField :: HasStack m => (FieldType -> m r) -> Dec -> Con -> FieldType -> m r+foldField :: MonadReaders [StackElement] 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@@ -128,7 +98,7 @@ execStackT action = runReaderT action []  -- | Re-implementation of stack accessor in terms of stackLens-stackAccessor :: (Quasi m, HasStack m) => ExpQ -> Type -> m Exp+stackAccessor :: (Quasi m, MonadReaders [StackElement] m) => ExpQ -> Type -> m Exp stackAccessor value typ0 =     withStack f     where@@ -138,7 +108,7 @@         Just typ <- stackType         runQ [| view $(pure lns) $value :: $(pure typ) |] -stackType :: HasStack m => m (Maybe Type)+stackType :: MonadReaders [StackElement] m => m (Maybe Type) stackType =     withStack (return . f)     where@@ -183,7 +153,7 @@ -- The only reason for this function is backwards compatibility, the -- fields should be changed so they begin with _ and the regular -- makeLenses should be used.-makeLenses' :: forall m. (DsMonad m, HasState ExpandMap m) => (Type -> m (Set Type)) -> [Name] -> m [Dec]+makeLenses' :: forall m. (DsMonad m, MonadStates ExpandMap m) => (Type -> m (Set Type)) -> [Name] -> m [Dec] makeLenses' extraTypes typeNames =     execWriterT $ execStackT $ makeTypeInfo (lift . lift . extraTypes) st >>= runReaderT typeGraphEdges >>= \ (g :: GraphEdges TGV) -> (mapM doType . map (view etype) . Map.keys . simpleEdges $ g)     where
Language/Haskell/TH/TypeGraph/TypeGraph.hs view
@@ -2,6 +2,7 @@  {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-}@@ -37,10 +38,11 @@ #else import Control.Applicative #endif-import Control.Lens -- (makeLenses, over, view)+import Control.Lens import Control.Monad (when)-import Control.Monad.Reader (ask, local, MonadReader, ReaderT, runReaderT)-import Control.Monad.State (execStateT, modify, StateT)+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.Trans (lift) import Data.Default (Default(def)) import Data.Foldable as Foldable@@ -58,11 +60,10 @@ import Language.Haskell.TH.PprLib (ptext) import Language.Haskell.TH.Syntax (Quasi(..)) import Language.Haskell.TH.TypeGraph.Edges (GraphEdges, simpleEdges)-import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)-import Language.Haskell.TH.TypeGraph.HasState (HasState(getState, modifyState))+import Language.Haskell.TH.TypeGraph.Expand (E(E), ExpandMap, expandType) import Language.Haskell.TH.TypeGraph.Prelude (adjacent', reachable') import Language.Haskell.TH.TypeGraph.TypeInfo (startTypes, TypeInfo, typeVertex', fieldVertex)-import Language.Haskell.TH.TypeGraph.Stack (HasStack(withStack, push), StackElement(StackElement))+import Language.Haskell.TH.TypeGraph.Stack (StackElement) import Language.Haskell.TH.TypeGraph.Vertex (TGV, TGVSimple, vsimple, TypeGraphVertex, etype) import Prelude hiding (any, concat, concatMap, elem, exp, foldr, mapM_, null, or) @@ -92,75 +93,78 @@  $(makeLenses ''TypeGraph) -instance Monad m => HasStack (ReaderT TypeGraph m) where-    withStack f = ask >>= f . view stack-    push fld con dec action = local (stack %~ (\s -> StackElement fld con dec : s)) action+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)) -allPathStarts :: forall m. (DsMonad m, HasState (Map Type (E Type)) m, MonadReader TypeGraph m) => m (Set TGV)+allPathStarts :: forall m. (DsMonad m, MonadStates (Map Type (E Type)) m, MonadReaders 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+  (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   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+ -- | Lenses represent steps in a path, but the start point is a type -- vertex and the endpoint is a field vertex.-allLensKeys ::  (DsMonad m, HasState (Map Type (E Type)) m, MonadReader TypeGraph m) => m (Map TGVSimple (Set TGV))+allLensKeys ::  (DsMonad m, MonadStates (Map Type (E Type)) m, MonadReaders TypeGraph m) => m (Map TGVSimple (Set TGV)) allLensKeys = do-  g <- view graph-  gs <- view gsimple+  g <- view' graph+  gs <- view' gsimple   allPathStarts >>= return . Map.fromListWith Set.union . List.map (\x -> (view vsimple x, Set.fromList (adjacent' g x))) . Set.toList  -- | Paths go between simple types.-allPathKeys :: (DsMonad m, HasState (Map Type (E Type)) m, MonadReader TypeGraph m) => m (Map TGVSimple (Set TGVSimple))+allPathKeys :: (DsMonad m, MonadStates (Map Type (E Type)) m, MonadReaders TypeGraph m) => m (Map TGVSimple (Set TGVSimple)) allPathKeys = do-  gs <- view gsimple+  gs <- view' gsimple   allPathStarts >>= return . Map.fromList . List.map (\x -> (x, Set.fromList (reachable' gs x))) . Set.toList . Set.map (view vsimple) -reachableFrom :: forall m. (DsMonad m, MonadReader TypeGraph m) => TGV -> m (Set TGV)+reachableFrom :: forall m. (DsMonad m, MonadReaders TypeGraph m) => TGV -> m (Set TGV) reachableFrom v = do   -- (g, vf, kf) <- graphFromMap <$> view edges-  (g, vf, kf) <- view graph+  (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 :: forall m. (DsMonad m, MonadReaders TypeGraph m) => TGVSimple -> m (Set TGVSimple) reachableFromSimple v = do   -- (g, vf, kf) <- graphFromMap <$> view edges-  (g, vf, kf) <- view gsimple+  (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+goalReachableFull :: (Functor m, DsMonad m, MonadReaders 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, MonadReaders TypeGraph m) => TGVSimple -> TGVSimple -> m Bool+goalReachableSimple gkey key0 = isReachable gkey key0 <$> view' gsimple -goalReachableSimple' :: (Functor m, DsMonad m, MonadReader TypeGraph m) => TGV -> TGV -> m Bool-goalReachableSimple' gkey key0 = isReachable (view vsimple gkey) (view vsimple key0) <$> view gsimple+goalReachableSimple' :: (Functor m, DsMonad m, MonadReaders TypeGraph m) => TGV -> TGV -> m Bool+goalReachableSimple' gkey key0 = isReachable (view vsimple gkey) (view vsimple key0) <$> view' gsimple  isReachable :: TypeGraphVertex key => key -> key -> (Graph, Vertex -> ((), key, [key]), key -> Maybe Vertex) -> Bool isReachable gkey key0 (g, _vf, kf) = path g (fromJust $ kf key0) (fromJust $ kf gkey)  -- | Return the TGV associated with a particular type, -- with no field specified.-typeGraphVertex :: (MonadReader TypeGraph m, HasState (Map Type (E Type)) m, DsMonad m) => Type -> m TGV+typeGraphVertex :: (MonadReaders TypeGraph m, MonadStates ExpandMap m, DsMonad m) => Type -> m TGV typeGraphVertex typ = do         typ' <- expandType typ-        ask >>= runReaderT (typeVertex' typ') . view typeInfo+        ask >>= MTL.runReaderT (typeVertex' typ') . view typeInfo         -- magnify typeInfo $ vertex Nothing typ'  -- | Return the TGV associated with a particular type and field.-typeGraphVertexOfField :: (MonadReader TypeGraph m, HasState (Map Type (E Type)) m, DsMonad m) => (Name, Name, Either Int Name) -> Type -> m TGV+typeGraphVertexOfField :: (MonadReaders TypeGraph m, MonadStates (Map Type (E Type)) m, DsMonad m) => (Name, Name, Either Int Name) -> Type -> m TGV typeGraphVertexOfField fld typ = do         typ' <- expandType typ-        ask >>= runReaderT (fieldVertex fld typ') . view typeInfo+        ask >>= MTL.runReaderT (fieldVertex fld typ') . view typeInfo         -- magnify typeInfo $ vertex (Just fld) typ'  -- type TypeGraphEdges typ = Map typ (Set typ)@@ -184,7 +188,7 @@ -- type aliases are expanded by the th-desugar package to make them -- suitable for use as map keys. typeGraphEdges'-    :: forall m. (DsMonad m, MonadReader TypeGraph m, HasState (Set TGV) m, HasState (Map Type (E Type)) m) =>+    :: 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@@ -201,9 +205,9 @@   execStateT (mapM_ (\typ -> lift (typeGraphVertex typ) >>= doNode) types) (mempty :: GraphEdges TGV)     where       doNode v = do-        (s :: Set TGV) <- lift $ getState+        (s :: Set TGV) <- lift get         when (not (member v s)) $-             do lift $ modifyState (Set.insert v)+             do lift $ modify (Set.insert v)                 doNode' v       doNode' :: TGV -> StateT (GraphEdges TGV) m ()       doNode' typ = do@@ -213,7 +217,7 @@         mapM_ doNode (Set.toList vs)        addNode :: TGV -> StateT (GraphEdges TGV) m ()-      addNode a = modify $ Map.alter (maybe (Just Set.empty) Just) a+      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@@ -221,7 +225,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. (MonadReader TypeGraph m, DsMonad m, HasState (Map Type (E Type)) m) => TGV -> m (Set TGV)+adjacent :: forall m. (MonadReaders TypeGraph m, DsMonad m, MonadStates (Map Type (E Type)) m) => TGV -> m (Set TGV) adjacent typ =     case view (vsimple . etype) typ of       E (ForallT _ _ typ') -> typeGraphVertex typ' >>= adjacent@@ -252,7 +256,7 @@       doField tname _dec cname (fld, ftype) = Set.singleton <$> typeGraphVertexOfField (tname, cname, fld) ftype  -- FIXME: pass in ti, pass in makeTypeGraphEdges, remove Q, move to TypeGraph.Graph-makeTypeGraph :: MonadReader TypeInfo m => (GraphEdges TGV) -> m TypeGraph+makeTypeGraph :: MonadReaders TypeInfo m => (GraphEdges TGV) -> m TypeGraph makeTypeGraph es = do   ti <- ask   return $ TypeGraph
Language/Haskell/TH/TypeGraph/TypeInfo.hs view
@@ -26,9 +26,9 @@ import Data.Monoid (mempty) #endif import Control.Lens -- (makeLenses, view)-import Control.Monad.Reader (MonadReader)-import Control.Monad.State (execStateT, StateT)-import Control.Monad.Trans as Monad (lift)+import Control.Monad.Readers (ask, MonadReaders)+import Control.Monad.Trans as Monad+import Control.Monad.States (execStateT, MonadStates(get, put), StateT) import Data.Foldable as Foldable (mapM_) import Data.List as List (intercalate, map) import Data.Map as Map (findWithDefault, insert, insertWith, Map, toList)@@ -39,8 +39,7 @@ import Language.Haskell.TH.Instances () import Language.Haskell.TH.PprLib (ptext) import Language.Haskell.TH.Syntax as TH (Lift(lift), Quasi(..))-import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)-import Language.Haskell.TH.TypeGraph.HasState (HasState(getState, modifyState))+import Language.Haskell.TH.TypeGraph.Expand (E(E), ExpandMap, expandType) import Language.Haskell.TH.TypeGraph.Prelude (pprint') import Language.Haskell.TH.TypeGraph.Shape (Field) import Language.Haskell.TH.TypeGraph.Vertex (TGV(..), TGVSimple(..), etype)@@ -76,9 +75,9 @@  $(makeLenses ''TypeInfo) -instance Monad m => HasState (Map Type (E Type)) (StateT TypeInfo m) where-    getState = use expanded-    modifyState f = expanded %= f+instance Monad m => MonadStates ExpandMap (StateT TypeInfo m) where+    get = use expanded+    put x = expanded .= x  instance Lift TypeInfo where     lift (TypeInfo {_startTypes = st, _typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f}) =@@ -162,7 +161,7 @@                 , _synonyms = mempty                 , _fields = mempty}) -allVertices :: (Functor m, DsMonad m, MonadReader TypeInfo m) => Maybe Field -> E Type -> m (Set TGV)+allVertices :: (Functor m, DsMonad m, MonadReaders TypeInfo m) => Maybe Field -> E Type -> m (Set TGV) allVertices (Just fld) etyp = singleton <$> fieldVertex fld etyp allVertices Nothing etyp = do   v <- typeVertex etyp@@ -173,27 +172,27 @@ -- 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 :: MonadReaders TypeInfo m => TGVSimple -> m (Set TGV) fieldVertices v = do-  fm <- view fields+  fm <- view fields <$> ask   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 :: forall m. (DsMonad m, MonadReaders 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 :: MonadReaders TypeInfo m => E Type -> m TGVSimple typeVertex etyp = do-  sm <- view synonyms+  sm <- view synonyms <$> ask   return $ TGVSimple {_syns = Map.findWithDefault Set.empty etyp sm, _etype = etyp} -typeVertex' :: MonadReader TypeInfo m => E Type -> m TGV+typeVertex' :: MonadReaders 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 :: MonadReaders TypeInfo m => Field -> E Type -> m TGV fieldVertex fld' etyp = typeVertex etyp >>= \v -> return $ TGV {_vsimple = v, _field = Just fld'}
test/Common.hs view
@@ -3,7 +3,8 @@  import Control.Applicative ((<$>)) import Control.Lens (view)-import Control.Monad.Reader (MonadReader, ReaderT)+import Control.Monad.Readers (MonadReaders, ReaderT)+import Control.Monad.States (MonadStates) import Data.Default (Default) import Data.List as List (intercalate, map) import Data.Map as Map (Map, filter, fromList, fromListWith, keys, toList)@@ -15,7 +16,6 @@ import Language.Haskell.TH.TypeGraph.Edges (GraphEdges) import Language.Haskell.TH.TypeGraph.Expand (E(unE)) import Language.Haskell.TH.TypeGraph.Edges (typeGraphEdges)-import Language.Haskell.TH.TypeGraph.HasState (HasState) import Language.Haskell.TH.TypeGraph.Prelude (pprint') import Language.Haskell.TH.TypeGraph.Shape (Field) import Language.Haskell.TH.TypeGraph.TypeInfo (TypeInfo)@@ -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, MonadReader TypeInfo m, HasState (Map Type (E Type)) m) => m (GraphEdges TGV)+typeGraphEdges' :: forall m. (DsMonad m, MonadReaders TypeInfo m, MonadStates (Map Type (E Type)) m) => m (GraphEdges TGV) typeGraphEdges' = typeGraphEdges  -- | Return a mapping from vertex to all the known type synonyms for -- the type in that vertex.-typeSynonymMap :: forall m. (DsMonad m, MonadReader TypeInfo m, HasState (Map Type (E Type)) m) =>+typeSynonymMap :: forall m. (DsMonad m, MonadReaders TypeInfo m, MonadStates (Map Type (E Type)) 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, MonadReader TypeInfo m, HasState (Map Type (E Type)) m) =>+typeSynonymMapSimple :: forall m. (DsMonad m, MonadReaders TypeInfo m, MonadStates (Map Type (E Type)) m) =>                         m (Map (E Type) (Set Name)) typeSynonymMapSimple =     simplify <$> typeSynonymMap
th-typegraph.cabal view
@@ -1,5 +1,5 @@ name:               th-typegraph-version:            0.24+version:            0.25 cabal-version:      >= 1.10 build-type:         Simple license:            BSD3@@ -17,6 +17,7 @@ extra-source-files: test/Common.hs test/Tests.hs test/TypeGraph.hs test/Values.hs  library+  hs-source-dirs: .   build-depends:     base >= 4.8 && < 5,     base-compat,@@ -25,6 +26,7 @@     haskell-src-exts,     lens,     mtl,+    mtl-unleashed >= 0.2.1,     set-extra,     syb,     template-haskell >= 2.10,@@ -36,7 +38,6 @@     Language.Haskell.TH.TypeGraph.Edges     Language.Haskell.TH.TypeGraph.Expand     Language.Haskell.TH.TypeGraph.Free-    Language.Haskell.TH.TypeGraph.HasState     Language.Haskell.TH.TypeGraph.Prelude     Language.Haskell.TH.TypeGraph.Shape     Language.Haskell.TH.TypeGraph.Stack@@ -50,7 +51,7 @@   hs-source-dirs:   test   main-is:          Tests.hs   build-depends:    array, base, bytestring, containers, data-default, deepseq, ghc-prim,-                    hspec, hspec-core, lens, mtl, syb, template-haskell, text,+                    hspec, hspec-core, lens, mtl, mtl-unleashed, syb, template-haskell, text,                     th-typegraph, th-desugar, th-orphans, th-reify-many   default-language: Haskell2010