packages feed

th-typegraph 0.18 → 0.21

raw patch · 17 files changed

+1129/−641 lines, 17 filesdep +base-compatdep +set-extradep ~basedep ~template-haskell

Dependencies added: base-compat, set-extra

Dependency ranges changed: base, template-haskell

Files

− Language/Haskell/TH/TypeGraph.hs 
@@ -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)
− Language/Haskell/TH/TypeGraph/Core.hs 
@@ -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
+ Language/Haskell/TH/TypeGraph/Edges.hs view
@@ -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)
Language/Haskell/TH/TypeGraph/Expand.hs view
@@ -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))|]
Language/Haskell/TH/TypeGraph/Free.hs view
@@ -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
Language/Haskell/TH/TypeGraph/Graph.hs view
@@ -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 = []+             }
Language/Haskell/TH/TypeGraph/Info.hs view
@@ -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'}
− Language/Haskell/TH/TypeGraph/Monad.hs 
@@ -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}
+ Language/Haskell/TH/TypeGraph/Prelude.hs view
@@ -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)
+ Language/Haskell/TH/TypeGraph/Shape.hs view
@@ -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]
+ Language/Haskell/TH/TypeGraph/Stack.hs view
@@ -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"
Language/Haskell/TH/TypeGraph/Unsafe.hs view
@@ -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
Language/Haskell/TH/TypeGraph/Vertex.hs view
@@ -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)}|]
test/Common.hs view
@@ -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))
test/TypeGraph.hs view
@@ -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
test/Values.hs view
@@ -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]",
th-typegraph.cabal view
@@ -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