packages feed

th-typegraph 0.14 → 0.17

raw patch · 15 files changed

+772/−586 lines, 15 files

Files

Language/Haskell/TH/TypeGraph.hs view
@@ -1,6 +1,5 @@ module Language.Haskell.TH.TypeGraph     ( module Language.Haskell.TH.TypeGraph.Core-    , module Language.Haskell.TH.TypeGraph.Edges     , module Language.Haskell.TH.TypeGraph.Expand     , module Language.Haskell.TH.TypeGraph.Graph     , module Language.Haskell.TH.TypeGraph.Hints@@ -10,12 +9,12 @@     , module Language.Haskell.TH.TypeGraph.Vertex     ) where -import Language.Haskell.TH.TypeGraph.Core-import Language.Haskell.TH.TypeGraph.Edges-import Language.Haskell.TH.TypeGraph.Expand-import Language.Haskell.TH.TypeGraph.Graph-import Language.Haskell.TH.TypeGraph.Hints-import Language.Haskell.TH.TypeGraph.Info-import Language.Haskell.TH.TypeGraph.Monad+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.Hints (VertexHint(Normal, Hidden, Sink, Divert, Extra))+import Language.Haskell.TH.TypeGraph.Info (TypeGraphInfo, fields, hints, 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+import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex, field, syns, etype, typeNames)
Language/Haskell/TH/TypeGraph/Core.hs view
@@ -3,47 +3,75 @@ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, RankNTypes, ScopedTypeVariables, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.TH.TypeGraph.Core-    ( -- * Declaration shape-      FieldType(FieldType, fPos, fNameAndType)+    ( unReify+    , unReifyName+    -- * Declaration shape+    , FieldType(FieldType, fPos, fNameAndType)+    , Field     , fName     , fType-    , prettyField     , constructorFields     , foldShape     -- * Constructor deconstructors     , constructorName     -- * Queries     , typeArity-    , unlifted     -- * Pretty print without extra whitespace     , pprint'     ) where -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>), (<*>))-#endif-import Data.Data (Data)+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 -prettyField :: FieldType -> String-prettyField fld = maybe (show (fPos fld)) nameBase (fName fld)+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@@ -106,35 +134,6 @@ -- 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  instance Lift a => Lift (Set a) where     lift s = [|Set.fromList $(lift (Set.toList s))|]
− Language/Haskell/TH/TypeGraph/Edges.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Language.Haskell.TH.TypeGraph.Edges-    ( TypeGraphEdges-    ) where--import Data.List as List (intercalate, map)-import Data.Map as Map (toList)-import Data.Set as Set (toList)-import Language.Haskell.Exts.Syntax ()-import Language.Haskell.TH -- (Con, Dec, nameBase, Type)-import Language.Haskell.TH.TypeGraph.Graph (GraphEdges)-import Language.Haskell.TH.TypeGraph.Core (pprint')-import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex)-import Language.Haskell.TH.Instances ()-import Language.Haskell.TH.PprLib (ptext)--type TypeGraphEdges = GraphEdges TypeGraphVertex--instance Ppr TypeGraphEdges where-    ppr x =-        ptext $ intercalate "\n  " $-          "edges:" : (List.map-                       (\ (k, ks) -> intercalate "\n    " ((pprint' k ++ "->") : List.map pprint' (Set.toList ks)))-                       (Map.toList x))
Language/Haskell/TH/TypeGraph/Expand.hs view
@@ -21,8 +21,8 @@ {-# LANGUAGE ScopedTypeVariables #-}  module Language.Haskell.TH.TypeGraph.Expand-    ( Expanded(markExpanded, runExpanded)-    , runExpanded'+    ( Expanded(markExpanded, runExpanded')+    , runExpanded     , expandType     , expandPred     , expandClassP@@ -42,7 +42,7 @@ -- specially marked expanded types or with the original types. class Expanded un ex | ex -> un where     markExpanded :: un -> ex -- ^ Unsafely mark a value as expanded-    runExpanded :: ex -> un -- ^ Strip mark off an expanded value+    runExpanded' :: ex -> un -- ^ Strip mark off an expanded value  -- | Apply the th-desugar expand function to a 'Type' and mark it as expanded. expandType :: (DsMonad m, Expanded Type e)  => Type -> m e@@ -54,8 +54,8 @@ #if MIN_VERSION_template_haskell(2,10,0) expandPred = expandType #else-expandPred (ClassP className typeParameters) = markExpanded <$> (ClassP className . map runExpanded') <$> mapM expandType typeParameters-expandPred (EqualP type1 type2) = markExpanded <$> (EqualP <$> (runExpanded' <$> expandType type1) <*> (runExpanded' <$> expandType type2))+expandPred (ClassP className typeParameters) = markExpanded <$> (ClassP className . map runExpanded) <$> mapM expandType 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'.@@ -64,23 +64,23 @@ #if MIN_VERSION_template_haskell(2,10,0)       (expandType $ foldl AppT (ConT className) typeParameters) :: m e #else-      (markExpanded . ClassP className . map runExpanded') <$> mapM expandType typeParameters+      (markExpanded . ClassP className . map runExpanded) <$> mapM expandType typeParameters #endif -runExpanded' :: Expanded a (E a) => E a -> a-runExpanded' = runExpanded+runExpanded :: Expanded a (E a) => E a -> a+runExpanded = runExpanded'  -- | A concrete type for which Expanded instances are declared below. newtype E a = E a deriving (Eq, Ord, Show)  instance Expanded Type (E Type) where     markExpanded = E-    runExpanded (E x) = x+    runExpanded' (E x) = x  #if !MIN_VERSION_template_haskell(2,10,0) instance Expanded Pred (E Pred) where     markExpanded = E-    runExpanded (E x) = x+    runExpanded' (E x) = x #endif  instance Ppr a => Ppr (E a) where
+ Language/Haskell/TH/TypeGraph/Free.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, TemplateHaskell #-}+module Language.Haskell.TH.TypeGraph.Free+    ( freeTypeVars+    ) 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.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++data St+    = St { _result :: Set Name+         , _stack :: Set Name+         } deriving Show++st0 :: St+st0 = St {_result = empty, _stack = empty}++$(makeLenses ''St)++freeTypeVars :: (FreeTypeVars t, Quasi m) => t -> m (Set Name)+freeTypeVars x = view result <$> execStateT (ftv x) st0++-- | This is based on the freeNamesOfTypes function from the+-- th-desugar package.+class FreeTypeVars t where+    ftv :: (Quasi m, MonadState St m) => t -> m ()++instance FreeTypeVars a => FreeTypeVars [a] where+    ftv ts = mapM_ ftv ts++instance FreeTypeVars Type where+    ftv (ForallT tvbs cx ty) = do+      ftv ty+      mapM_ go_pred cx+      result %= (`Set.difference` (Set.fromList (map tvbName tvbs)))+        where+#if MIN_VERSION_template_haskell(2,10,0)+          go_pred typ =+              -- This looks wrong as the one below looks wrong.  Wronger maybe.+              ftv typ+#else+          go_pred (ClassP _ tys) = ftv tys+          go_pred (EqualP t1 t2) = do+            -- This looks wrong - we need to unify t1 and t2 and look+            -- at the free type variables in the resulting bindings+            ftv t1+            ftv t2+#endif+    ftv (SigT ty _) = ftv ty+    ftv (VarT n) = result %= Set.insert n+    ftv (AppT t1 t2) = {-trace ("go_app " ++ show typ) (return ()) >>-} go_app [t2] t1+    ftv typ@(ConT _) = {-trace ("go_app " ++ show typ) (return ()) >>-} go_app [] typ+    ftv _ = return ()+++go_app :: (Quasi m, MonadState St m) => [Type] -> Type -> m ()+go_app params (AppT t1 t2) = go_app (t2 : params) t1+go_app params (ConT n) = do+    stk <- use stack+    case Set.member n stk of+      True -> return ()+      False -> do+        stack %= Set.insert n+        qReify n >>= go_info (reverse params)+go_app params typ = mapM_ ftv (typ : params)+go_info :: (Quasi m, MonadState St m) => [Type] -> Info -> m ()+go_info params (TyConI dec) = go_dec params ({-trace ("go_dec " ++ show dec)-} dec)+go_info params (FamilyI dec _insts) = go_dec params dec+go_info _params (PrimTyConI _name _arity _unlifed) = return ()+go_info _params info = error $ "go_info - unexpected: " ++ pprint' info+go_dec :: (Quasi m, MonadState St m) => [Type] -> Dec -> m ()+go_dec params (NewtypeD cx tname tvs con supers) = go_dec params (DataD cx tname tvs [con] supers)+go_dec params (DataD _ tname tvs _ _) | length params > length tvs = error $ "Too many arguments to " ++ show tname+go_dec params (DataD _cx tname tvs cons _supers) = do+  -- For each type variable bound to a type parameter,+  -- replace the type variable with the free variables+  -- in the parameter+  ftv cons+  go_params tname tvs params+go_dec params (TySynD tname tvs typ) = do+  -- Add the free variables in the type, then subtract the ones that+  -- are bound here.+  ftv typ+  go_params tname tvs params++-- I have a feeling this is utterly wrong.  Example, with this class:+--+-- class OrderKey k => OrderMap k where+--    data Order k :: * -> *+--    ...+--+-- the resulting declaration of Order is+--+--    FamilyD DataFam Language.Haskell.TH.Path.Order.Order [PlainTV k,PlainTV $a] (Just StarT)+--    params=[ConT AbbrevPairID]+--+-- so the parameter is bound to k, and $a should be free.+go_dec params (FamilyD _flavour tname tvs _mkind) = go_params tname tvs params+go_dec params dec = error $ "go_dec - unexpected: " ++ pprint' dec ++ ", params=" ++ show params++go_params :: (Quasi m, MonadState St m) => Name -> [TyVarBndr] -> [Type] -> m ()+go_params tname tvs params | length params  > length tvs = error $ "Too many arguments to " ++ show tname+go_params _ tvs params = mapM_ (uncurry go_param) (zip tvs (map Just params ++ repeat Nothing))++-- | Update the free variable set for a type parameter+go_param :: (Quasi m, MonadState St m) => TyVarBndr -> Maybe Type -> m ()+go_param tvb (Just param) = do+  -- If there is a binding, add the free variables found in the type+  -- and remove the variable bound here+  -- trace ("go_param " ++ "(" ++ pprint tvb ++ ", " ++ pprint' param ++ ")") (return ())+  ftv param+  result %= Set.delete (tvbName tvb)+  -- let tv = tvbName tvb+  -- r <- use result+  -- when (Set.member tv r) (ftv param >> result %= Set.delete tv)+go_param tvb Nothing = do+  -- If there is a variable not bound to a type parameter it is fee+  result %= Set.insert (tvbName tvb)++{-+instance FreeTypeVars Info where+    ftv (TyConI dec) = ftv dec++instance FreeTypeVars Dec where+    ftv dec@(DataD _ _ _ _ _ _) = ftv dec+#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+-}++instance FreeTypeVars Con where+    ftv (NormalC _name sts) = ftv sts+    ftv (RecC _name vsts) = ftv vsts+    ftv (InfixC st1 _ st2) = ftv [st1, st2]+    -- I'm not sure what effect this forall has.+    ftv (ForallC _tvbs _cx con) = ftv con++instance FreeTypeVars (Strict, Type) where+    ftv (_, typ) = ftv typ++instance FreeTypeVars (Name, Strict, Type) where+    ftv (_, _, typ) = ftv typ++-- | Extract a 'Name' from a 'TyVarBndr'+tvbName :: TyVarBndr -> Name+tvbName (PlainTV n)    = n+tvbName (KindedTV n _) = n
Language/Haskell/TH/TypeGraph/Graph.hs view
@@ -1,88 +1,104 @@ -- | Abstract operations on Maps containing graph edges. +-- FIXME: the sense of the predicates are kinda mixed up here+ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE TypeFamilies #-}  module Language.Haskell.TH.TypeGraph.Graph     ( GraphEdges-    , cutVertex-    , cutVertices-    , cutVerticesM-    , mergeVertex-    , mergeVertices-    , mergeVerticesM-    , partitionM-    , flatten     , graphFromMap+    , cut+    , cutM+    , isolate+    , isolateM+    , dissolve+    , dissolveM     ) where +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Control.Lens (over, _2) import Control.Monad (filterM)+import Data.Foldable as Foldable import Data.Graph hiding (edges)-import Data.List as List-import Data.Map as Map-import Data.Set as Set--type GraphEdges v = Map v (Set v)---- | Remove a node and all its in- and out-edges.-cutVertex :: (Eq a, Ord a) => a -> GraphEdges a -> GraphEdges a-cutVertex victim edges = Map.map (Set.filter (/= victim)) $ Map.filterWithKey (\k _ -> k /= victim) edges---- | Cut vertices for which the predicate returns False-cutVertices :: (Eq a, Ord a) => (a -> Bool) -> GraphEdges a -> GraphEdges a-cutVertices victim edges = List.foldr cutVertex edges (List.filter victim (Map.keys edges))---- | Cut vertices for which the predicate returns False-cutVerticesM :: (Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges a -> m (GraphEdges a)-cutVerticesM victim edges = do-  victims <- filterM victim (Map.keys edges) >>= return . Set.fromList-  return $ cutVertices (`Set.member` victims) edges---- | Merge a node into the nodes that are its in-edges.-mergeVertex :: (Eq a, Ord a) => a -> GraphEdges a -> GraphEdges a-mergeVertex victim edges =-  survivorEdges'-    where-      -- Wherever the victim vertex appears as an out-edge, substitute the victimOut set-      survivorEdges' = Map.mapWithKey (\ k s -> if Set.member victim s then Set.union (Set.delete victim s) (Set.delete k victimOut) else s) survivorEdges-      -- Split map into victim vertex and other vertices-      (victimEdges, survivorEdges) = partitionWithKey (\ v _ -> (v == victim)) edges-      -- Get the out-edges of the victim vertex-      victimOut = Set.delete victim $ Set.unions $ Map.elems victimEdges--mergeVertices :: (Eq a, Ord a) => (a -> Bool) -> GraphEdges a -> GraphEdges a-mergeVertices keep edges = List.foldr mergeVertex edges (List.filter (not . keep) (Map.keys edges))--mergeVerticesM :: (Monad m, Ord  a) => (a -> m Bool) -> GraphEdges a -> m (GraphEdges a)-mergeVerticesM predicateM edges =-    mapM predicateM (Map.keys edges) >>= \flags -> return $ mergeVertices (makePredicate (zip (Map.keys edges) flags)) edges-    where-      makePredicate :: Ord a => [(a, Bool)] -> a -> Bool-      makePredicate pairs = flip (Map.findWithDefault False) (Map.fromList pairs)--partitionM :: forall m a. Monad m => (a -> m Bool) -> [a] -> m ([a], [a])-partitionM p l = do-  (flags :: [Bool]) <- mapM p l-  let pairs :: [(a, Bool)]-      pairs = zip l flags-      as :: [(a, Bool)]-      bs :: [(a, Bool)]-      (as, bs) = List.partition snd pairs-  return $ (List.map fst as, List.map fst bs)+import Data.List as List (intercalate, map)+import Data.Map as Map (Map, elems, filterWithKey, keys, map, mapWithKey, partitionWithKey)+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 Language.Haskell.TH.PprLib (ptext)+import Language.Haskell.TH.TypeGraph.Core (pprint')+import Prelude hiding (foldr) -flatten :: Ord a => Set (Set a) -> Set a-flatten = Set.fold Set.union Set.empty+type GraphEdges label key = Map key (label, Set key) +instance Ppr key => Ppr (GraphEdges label key) where+    ppr x =+        ptext $ intercalate "\n  " $+          "edges:" : (List.map+                       (\(k, (_, ks)) -> intercalate "\n    " ((pprint' k ++ " ->") : List.map pprint' (toList ks)))+                       (Map.toList x))  -- | Build a graph from the result of typeGraphEdges, each edge goes -- from a type to one of the types it contains.  Thus, each edge -- represents a primitive lens, and each path in the graph is a -- composition of lenses.-graphFromMap :: forall node key a. (Ord a, node ~ a, key ~ a) =>-                GraphEdges a -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)+graphFromMap :: forall label key. (Ord key) =>+                GraphEdges label key -> (Graph, Vertex -> (label, key, [key]), key -> Maybe Vertex) graphFromMap mp =     graphFromEdges triples     where-      triples :: [(node, key, [key])]-      triples = List.map (\ (k, ks) -> (k, k, Set.toList ks)) $ Map.toList mp+      triples :: [(label, key, [key])]+      triples = List.map (\ (k, (node, ks)) -> (node, k, toList ks)) $ Map.toList mp++-- | Isolate and remove some nodes+cut :: (Eq a, Ord a) => Set a -> GraphEdges label a -> GraphEdges label a+cut victims edges = Map.filterWithKey (\v _ -> not (Set.member v victims)) (isolate victims edges)++-- | Monadic predicate version of 'cut'.+cutM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges label a -> m (GraphEdges label a)+cutM victim edges = do+  victims <- Set.fromList <$> filterM victim (Map.keys edges)+  return $ cut victims edges++-- | Remove all the in- and out-edges of some nodes+isolate :: (Eq a, Ord a) => Set a -> GraphEdges label a -> GraphEdges label a+isolate victims edges =+    edges''+    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++-- | Monadic predicate version of 'isolate'.+isolateM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges label a -> m (GraphEdges label a)+isolateM victim edges = do+  victims <- Set.fromList <$> filterM victim (Map.keys edges)+  return $ isolate victims edges++-- | Remove some nodes and extend each of their in-edges to each of+-- their out-edges+dissolve :: (Eq a, Ord a) => Set a -> GraphEdges label a -> GraphEdges label a+dissolve victims edges0 = foldr dissolve1 edges0 victims+    where+      dissolve1 :: (Eq a, Ord a) => a -> GraphEdges label a -> GraphEdges label 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++-- | Monadic predicate version of 'dissolve'.+dissolveM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges label a -> m (GraphEdges label a)+dissolveM victim edges = do+  victims <- Set.fromList <$> filterM victim (Map.keys edges)+  return $ dissolve victims edges
Language/Haskell/TH/TypeGraph/Hints.hs view
@@ -11,11 +11,14 @@ {-# OPTIONS_GHC -Wall #-} module Language.Haskell.TH.TypeGraph.Hints     ( VertexHint(..)+    , HasVertexHints(hasVertexHints)+    , vertexHintTypes     ) where  import Data.Default (Default(def)) 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))@@ -23,11 +26,11 @@ -- | When a VertexHint value is associated with a Type it describes -- alterations in the type graph from the usual default. data VertexHint-    = Normal      -- ^ normal case-    | Hidden      -- ^ don't create this vertex, no in or out edges-    | Sink        -- ^ out degree zero - don't create any out edges-    | Divert Type -- ^ replace all out edges with an edge to an alternate type-    | Extra Type  -- ^ add an extra out edge to the given type+    = Normal          -- ^ normal case+    | Hidden          -- ^ don't create this vertex, no in or out edges+    | Sink            -- ^ out degree zero - don't create any out edges+    | Divert Type     -- ^ replace all out edges with an edge to an alternate type+    | Extra Type      -- ^ add an extra out edge to the given type     deriving (Eq, Ord, Show)  instance Default VertexHint where@@ -46,3 +49,14 @@     ppr Sink = ptext "Sink"     ppr (Divert x) = hcat [ptext "Divert (", ppr x, ptext ")"]     ppr (Extra x) = hcat [ptext "Extra (", ppr x, ptext ")"]++vertexHintTypes :: VertexHint -> [Type]+vertexHintTypes (Divert x) = [x]+vertexHintTypes (Extra x) = [x]+vertexHintTypes _ = []++class HasVertexHints hint where+    hasVertexHints :: DsMonad m => hint -> m [VertexHint]++instance HasVertexHints VertexHint where+    hasVertexHints h = return [h]
Language/Haskell/TH/TypeGraph/Info.hs view
@@ -13,27 +13,22 @@     ( TypeGraphInfo     , emptyTypeGraphInfo     , typeGraphInfo-    , expanded, fields, hints, infoMap, synonyms, typeSet-    , withTypeGraphInfo+    , fields, hints, infoMap, synonyms, typeSet     ) where  #if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>)) import Data.Monoid (mempty) #endif import Control.Lens -- (makeLenses, view)-import Control.Monad.Reader (ReaderT, runReaderT) import Control.Monad.State (execStateT, StateT) import Data.List as List (intercalate, map)-import Data.Map as Map (elems, fromListWith, insert, insertWith, Map, toList)-import Data.Maybe (mapMaybe)+import Data.Map as Map (insert, insertWith, Map, toList) import Data.Set as Set (insert, 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.Core (Field, pprint') import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)-import Language.Haskell.TH.TypeGraph.Hints (VertexHint(..))-import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex)+import Language.Haskell.TH.TypeGraph.Hints (HasVertexHints(hasVertexHints), vertexHintTypes) import Language.Haskell.TH.Desugar as DS (DsMonad) import Language.Haskell.TH.Instances () import Language.Haskell.TH.PprLib (ptext)@@ -41,73 +36,70 @@  -- | Information collected about the graph implied by the structure of -- one or more 'Type' values.-data TypeGraphInfo+data TypeGraphInfo hint     = TypeGraphInfo       { _typeSet :: Set Type-      -- All the types encountered, including embedded types such as the+      -- ^ All the types encountered, including embedded types such as the       -- 'Maybe' and the 'Int' in @Maybe Int@.       , _infoMap :: Map Name Info-      -- The Info record of all known named types+      -- ^ The Info record of all known named types       , _expanded :: Map Type (E Type)-      -- The types with all type synonyms replaced with their expansions.+      -- ^ Map of the expansion of all encountered types       , _synonyms :: Map (E Type) (Set Name)-      -- Map from field type to field names+      -- ^ The types with all type synonyms replaced with their expansions.       , _fields :: Map (E Type) (Set (Name, Name, Either Int Name))-{--      -- Map from type name to the field names that type contains-      , _decfields :: Map Name (Set (Name, Name, Either Int Name))-      -- Information about record fields which contain a given type-      , _edges :: GraphEdges TypeGraphVertex--}-      -- The edges of the "has this subtype" graph.  A type has-      -- subtypes via either type application ('AppT'), field type-      -- ('StrictType', 'VarStrictType') or the 'VertexHint'-      -- mechanism.-      , _hints :: Map TypeGraphVertex [VertexHint]+      -- ^ Map from field type to field names+      , _hints :: [(Maybe Field, Name, hint)]+      -- ^ Hints that modify the shape of the type graph. The key is the+      -- raw type and field values that are later used to construct+      -- the TypeGraphVertex, it is unsafe to do that until+      -- TypeGraphInfo is finalized.       } deriving (Show, Eq, Ord) -instance Ppr TypeGraphInfo where-    ppr (TypeGraphInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f, _hints = h}) =+instance Ppr hint => Ppr (TypeGraphInfo hint) where+    ppr (TypeGraphInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f, _hints = hs}) =         ptext $ intercalate "\n  " ["TypeGraphInfo:", ppt, ppi, ppe, pps, ppf, pph] ++ "\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))           ppe = intercalate "\n    " ("expanded:" : concatMap (lines . (\ (typ, (E etyp)) -> pprint typ ++ " -> " ++ pprint etyp)) (Map.toList e))-          pps = intercalate "\n    " ("synonyms:" : concatMap (lines . (\ (E etyp, ns) -> pprint etyp ++ " -> " ++ show ns)) (Map.toList s))-          ppf = intercalate "\n    " ("fields:" : concatMap (lines . (\ (E etyp, fs) -> pprint etyp ++ " -> " ++ show fs)) (Map.toList f))-          pph = intercalate "\n    " ("hints:" : concatMap (lines . (\ (v, hs) -> pprint v ++ " -> " ++ intercalate " " (map pprint hs))) (Map.toList h))+          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))+          pph = intercalate "\n    " ("hints:" : concatMap (lines . (\ (fld, tname, h) -> pprint (fld, (ConT tname)) ++ " -> " ++ pprint h)) hs)  $(makeLenses ''TypeGraphInfo) -emptyTypeGraphInfo :: TypeGraphInfo-emptyTypeGraphInfo = TypeGraphInfo {_typeSet = mempty, _infoMap = mempty, _expanded = mempty, _synonyms = mempty, _fields = mempty, _hints = mempty}+instance Lift hint => Lift (TypeGraphInfo hint) where+    lift (TypeGraphInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f, _hints = h}) =+        [| TypeGraphInfo { _typeSet = $(lift t)+                         , _infoMap = $(lift i)+                         , _expanded = $(lift e)+                         , _synonyms = $(lift s)+                         , _fields = $(lift f)+                         , _hints = $(lift h)+                         } |] -withTypeGraphInfo :: forall m a. DsMonad m => [(TypeGraphVertex, VertexHint)] -> [Type] -> ReaderT TypeGraphInfo m a -> m a-withTypeGraphInfo hintList types action = typeGraphInfo hintList types >>= runReaderT action+emptyTypeGraphInfo :: TypeGraphInfo hint+emptyTypeGraphInfo = TypeGraphInfo {_typeSet = mempty, _infoMap = mempty, _expanded = mempty, _synonyms = mempty, _fields = mempty, _hints = mempty} --- | Build a TypeGraphInfo value by scanning the supplied types and hints.-typeGraphInfo :: forall m. DsMonad m => [(TypeGraphVertex, VertexHint)] -> [Type] -> m TypeGraphInfo-typeGraphInfo hintList types = flip execStateT emptyTypeGraphInfo $ do-  hints .= Map.fromListWith (++) (List.map (\ (n, h) -> (n, [h])) hintList)-  hintTypes <- (mapMaybe hintType . concat . Map.elems) <$> use hints-  mapM_ doType (types ++ hintTypes)+-- | Collect the graph information for one type and all the types+-- reachable from it.+collectTypeInfo :: forall m hint. (DsMonad m, HasVertexHints hint) => Type -> StateT (TypeGraphInfo hint) m ()+collectTypeInfo typ0 = do+  doType typ0     where-      hintType :: VertexHint -> Maybe Type-      hintType (Divert x) = Just x-      hintType (Extra x) = Just x-      hintType _ = Nothing--      doType :: Type -> StateT TypeGraphInfo m ()+      doType :: Type -> StateT (TypeGraphInfo hint) m ()       doType typ = do         (s :: Set Type) <- use typeSet         case Set.member typ s of           True -> return ()           False -> do typeSet %= Set.insert typ-                      etyp <- expandType typ+                      etyp{-@(E etyp')-} <- expandType typ                       expanded %= Map.insert typ etyp+                      -- 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 (TypeGraphInfo hint) m ()       doType' (ConT name) = do         info <- qReify name         infoMap %= Map.insert name info@@ -118,143 +110,40 @@       doType' (TupleT _) = return ()       doType' typ = error $ "typeGraphInfo: " ++ pprint' typ -      doInfo :: Name -> Info -> StateT TypeGraphInfo m ()+      doInfo :: Name -> Info -> StateT (TypeGraphInfo hint) 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 -      doDec :: Dec -> StateT TypeGraphInfo m ()+      doDec :: Dec -> StateT (TypeGraphInfo hint) m ()       doDec (TySynD tname _ typ) = do-        etyp <- expandType typ+        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 -      doCon :: Name -> Con -> StateT TypeGraphInfo m ()+      doCon :: Name -> Con -> StateT (TypeGraphInfo hint) 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 (TypeGraphInfo hint) m ()       doField (fld, ftyp) = do         etyp <- expandType ftyp-        expanded %= Map.insert ftyp etyp         fields %= Map.insertWith union etyp (singleton fld)         doType ftyp -#if 0-  (ex :: Map Type (E Type)) <- findExpanded types'-  (sy :: Map (E Type) (Set Name)) <--      -- Build the type synonym map and then expand the types in its-      -- keys.  This will collapse some of the nodes if they differed-      -- only in the use of synonyms.-      findSynonyms types' >>= return . Map.fromListWith union . List.map (\ (typ, names) -> (expand ex typ, names))  . Map.toList-  fl <- findFields types' >>= return . Map.fromListWith union . List.map (\ (typ, names) -> (expand ex typ, names))  . Map.toList-  -- ed <- findEdges types' ex sy -- >>= return . Map.fromListWith union . List.map (\ (typ, dests) -> (expand ex typ, Set.map (expand ex) dests)) . Map.toList-  let etypes' = Set.fromList $ List.map (expand ex) (Set.toList types')-  return $ TypeGraphInfo { _expanded = ex-                         , _synonyms = sy-                         , _fields = fl-                         , _typeSet = etypes'-                         , _hints =  Map.fromListWith (++) (List.map (\ (n, h) -> (n, [h])) hintList)-                         }-      where expand ex typ = let Just etyp = Map.lookup typ ex in etyp-#endif--#if 0--- | This is now the only function that actually recurses through the--- type structure.  It collects the set of all accessable types.-scanTypes :: forall m. DsMonad m => [Type] -> StateT TypeGraphInfo m ()-scanTypes types =-    mapM doType types-    where-      doType :: Type -> StateT (Set Type) m ()-      doType typ = do-        (s :: Set Type) <- get-        case Set.member typ s of-          True -> return ()-          False -> modify (\ (ts, im) -> (Set.insert typ ts, im)) >> doType' typ--      doType' :: Type -> StateT (Set Type) m ()-      doType' (ConT name) = qReify name >>= \info -> modify (\ (ts, im) -> (ts, Map.insert name info im)) >> doInfo name-      doType' (AppT typ1 typ2) = doType typ1 >> doType typ2-      doType' ListT = return ()-      doType' (VarT _) = return ()-      doType' (TupleT _) = return ()-      doType' typ = error $ "scanTypes: " ++ show typ--      doInfo :: Name -> Info -> StateT (Set Type) m ()-      doInfo _tname (TyConI dec) = doDec dec-      doInfo _tname (PrimTyConI _ _ _) = return ()-      doInfo _tname (FamilyI _ _) = return () -- Not sure what to do here-      doInfo _ info = error $ "scanTypes: " ++ show info--      doDec :: Dec -> StateT (Set Type) m ()-      doDec (TySynD _ _ typ) = doType typ-      doDec (NewtypeD _ _ _ constr _) = doCon constr-      doDec (DataD _ _ _ constrs _) = mapM_ doCon constrs-      doDec dec = error $ "scanTypes: " ++ pprint' dec--      doCon :: Con -> StateT (Set Type) m ()-      doCon (ForallC _ _ con) = doCon con-      doCon (NormalC _ flds) = mapM_ doField (zip (List.map Left ([1..] :: [Int])) (List.map snd flds))-      doCon (RecC _ flds) = mapM_ doField (List.map (\ (fname, _, ftype) -> (Right fname, ftype)) flds)-      doCon (InfixC (_, lhs) _ (_, rhs)) = mapM_ doField [(Left 1, lhs), (Left 2, rhs)]--      doField :: (Either Int Name, Type) -> StateT (Set Type) m ()-      doField (_, ftyp) = doType ftyp---- | Discover the types with all type synonyms fully expanded.-findExpanded :: DsMonad m => Set Type -> m (Map Type (E Type))-findExpanded types =-    execStateT (mapM (\typ -> expandType typ >>= \etyp -> modify (Map.insert typ etyp)) (Set.toList types)) mempty---- | Discover the type synonyms-findSynonyms :: DsMonad m => Set Type -> m (Map Type (Set Name))-findSynonyms types =-    execStateT (mapM_ doType (Set.toList types)) mempty-    where-      doType (ConT name) = qReify name >>= doInfo-      doType (AppT typ1 typ2) = doType typ1 >> doType typ2-      doType _ = return ()-      doInfo (TyConI dec) = doDec dec-      doInfo _ = return ()-      doDec (TySynD tname _ typ) = modify (Map.insertWith union typ (singleton tname))-      doDec _ = return ()---- | Discover the field types-findFields :: DsMonad m => Set Type -> m (Map Type (Set (Name, Name, Either Int Name)))-findFields types =-    execStateT (mapM_ doType (Set.toList types)) mempty-    where-      doType (ConT name) = qReify name >>= doInfo-      doType (AppT typ1 typ2) = doType typ1 >> doType typ2-      doType _ = return ()--      doInfo (TyConI dec) = doDec dec-      doInfo _ = return ()--      doDec (NewtypeD _ tname _ constr _) = doCon tname constr-      doDec (DataD _ tname _ constrs _) = mapM_ (doCon tname) constrs-      doDec _ = return ()--      doCon tname (ForallC _ _ con) = doCon tname con-      doCon tname (NormalC cname flds) = mapM_ (doField tname cname) (zip (List.map Left ([1..] :: [Int])) (List.map snd flds))-      doCon tname (RecC cname flds) = mapM_ (doField tname cname) (List.map (\ (fname, _, ftype) -> (Right fname, ftype)) flds)-      doCon tname (InfixC (_, lhs) cname (_, rhs)) = mapM_ (doField tname cname) [(Left 1, lhs), (Left 2, rhs)]--      doField tname cname (fname, ftyp) = modify (Map.insertWith union ftyp (singleton (tname, cname, fname)))-#endif+-- | Add a hint to the TypeGraphInfo state and process any type it+-- might contain.+collectHintInfo :: (DsMonad m, HasVertexHints hint) => (Maybe Field, Name, hint) -> StateT (TypeGraphInfo hint) m ()+collectHintInfo (fld, tname, h) = hints %= (++ [(fld, tname, h)]) -instance Lift TypeGraphInfo where-    lift (TypeGraphInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f, _hints = h}) =-        [| TypeGraphInfo {_typeSet = $(lift t),-                          _infoMap = $(lift i),-                          _expanded = $(lift e),-                          _synonyms = $(lift s),-                          _fields = $(lift f),-                          _hints = $(lift h)} |]+-- | Build a TypeGraphInfo value by scanning the supplied types and hints.+typeGraphInfo :: forall m hint. (DsMonad m, HasVertexHints hint) => [(Maybe Field, Name, hint)] -> [Type] -> m (TypeGraphInfo hint)+typeGraphInfo hintList types = flip execStateT emptyTypeGraphInfo $ do+  mapM hasVertexHints (List.map (view _3) hintList) >>= mapM_ collectTypeInfo . (types ++) . concatMap vertexHintTypes . concat+  mapM_ collectHintInfo hintList
Language/Haskell/TH/TypeGraph/Monad.hs view
@@ -1,3 +1,5 @@+-- | Operations using @MonadReader (TypeGraphInfo hint)@.+ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -10,189 +12,188 @@ {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall #-} module Language.Haskell.TH.TypeGraph.Monad-    ( findEdges+    ( fieldVertices+    , allVertices+    , vertex     , typeVertex     , fieldVertex-    -- , typeVertices     , typeGraphEdges-    , typeGraphVertices-    , typeGraph     , simpleEdges     , simpleVertex-    , typeSynonymMap-    , typeSynonymMapSimple     ) where  #if __GLASGOW_HASKELL__ < 709-import Control.Applicative+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.Graph (Graph, Vertex)+import Data.Default (Default(def)) import Data.List as List (map)-import Data.Map as Map ((!), filter, findWithDefault, fromList, fromListWith,-                        keys, Map, map, mapKeys, mapWithKey, toList, alter)-import Data.Maybe (fromMaybe)-import Data.Set as Set (delete, empty, fromList, insert, map, null, Set, singleton, toList, union)+import Data.Map as Map ((!), findWithDefault, map, mapKeys, mapWithKey, alter)+import Data.Set as Set (delete, empty, insert, map, Set, singleton) import Language.Haskell.Exts.Syntax () import Language.Haskell.TH -- (Con, Dec, nameBase, Type)-import Language.Haskell.TH.TypeGraph.Expand (E(E))-import Language.Haskell.TH.TypeGraph.Graph (cutVertex, GraphEdges, graphFromMap)-import Language.Haskell.TH.TypeGraph.Edges (TypeGraphEdges)-import Language.Haskell.TH.TypeGraph.Hints (VertexHint(..))-import Language.Haskell.TH.TypeGraph.Info (TypeGraphInfo, expanded, fields, hints, infoMap, synonyms, typeSet)-import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..), etype, field)+import Language.Haskell.TH.TypeGraph.Core (Field)+import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)+import Language.Haskell.TH.TypeGraph.Graph (cut, GraphEdges)+import Language.Haskell.TH.TypeGraph.Hints (HasVertexHints(hasVertexHints), VertexHint(..))+import Language.Haskell.TH.TypeGraph.Info (TypeGraphInfo, fields, hints, infoMap, synonyms, typeSet)+import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..), etype, field, typeNames) import Language.Haskell.TH.Desugar as DS (DsMonad) import Language.Haskell.TH.Instances ()+import Prelude hiding (foldr, mapM_, null) --- | Build a TypeGraphVertex from an unexpanded type.-typeVertex :: MonadReader TypeGraphInfo m => E Type -> m TypeGraphVertex+import Data.Foldable (mapM_)+#if MIN_VERSION_base(4,8,0)+import Data.Foldable (null)+#else+import Data.Foldable (Foldable, foldr)+null :: Foldable t => t a -> Bool+null = foldr (\_ _ -> False) True+#endif++allVertices :: (Functor m, DsMonad m, MonadReader (TypeGraphInfo hint) 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 hint) 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 hint. (DsMonad m, MonadReader (TypeGraphInfo hint) m) => Maybe Field -> E Type -> m TypeGraphVertex+vertex fld etyp = maybe (typeVertex etyp) (fieldVertex etyp) fld++-- | Build a non-field vertex+typeVertex :: MonadReader (TypeGraphInfo hint) 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 TypeGraphVertex for a field of a record.  This calls--- 'typeVertex' and then sets the _field value.-fieldVertex :: MonadReader TypeGraphInfo m => E Type -> (Name, Name, Either Int Name) -> m TypeGraphVertex-fieldVertex typ fld = typeVertex typ >>= \vertex -> return $ vertex {_field = Just fld}---- | Return the set of vertices referred to by a hint's vertex - if--- field is Nothing it means all the fields with that type, if it is--- something it means just itself.-fieldVertices :: MonadReader TypeGraphInfo m => TypeGraphVertex -> m (Set TypeGraphVertex)-fieldVertices v =-    case view field v of-      Just _ -> return $ singleton v-      Nothing -> do-        fm <- view fields-        let fs = Map.findWithDefault Set.empty (view etype v) fm-            vs = Set.map (\fld -> set field (Just fld) v) fs-        return $ Set.insert v vs+-- | Build a vertex associated with a field+fieldVertex :: MonadReader (TypeGraphInfo hint) m => E Type -> Field -> m TypeGraphVertex+fieldVertex etyp fld' = typeVertex etyp >>= \v -> return $ v {_field = Just fld'} --- | Start with the type graph on the known types with no field--- information, and build a new graph which incorporates the--- information from the vertex hints.  This means splitting the nodes--- according to record fields, because hints can refer to particular--- fields of a record.-typeGraphEdges :: forall m. MonadReader TypeGraphInfo m => m TypeGraphEdges+-- | Start with the type graph on the known types, and build a new+-- graph which incorporates the information from the hints.+typeGraphEdges :: forall m hint. (DsMonad m, Default hint, Eq hint, HasVertexHints hint, MonadReader (TypeGraphInfo hint) m) =>+                  m (GraphEdges hint TypeGraphVertex) typeGraphEdges = do-  findEdges >>= execStateT (view hints >>= mapM (uncurry doHint) . concat . List.map (\ (a, bs) -> List.map (a,) bs) . Map.toList)+  findEdges {->>= t1-} >>= execStateT (view hints >>= mapM doHint) {->>= t2-}     where-      doHint :: TypeGraphVertex -> VertexHint -> StateT TypeGraphEdges m ()-      doHint v Sink = fieldVertices v >>= mapM_ (modify . Map.alter (\_ -> Just Set.empty)) . Set.toList-      doHint _ Normal = return ()-      doHint v Hidden = fieldVertices v >>= mapM_ (modify . cutVertex) . Set.toList-      doHint v (Divert typ) = do-        em <- view expanded-        v' <- typeVertex (em ! typ)-        fieldVertices v >>= mapM_ (modify . Map.alter (\_ -> Just (singleton v'))) . Set.toList-      doHint v (Extra typ) = do-        em <- view expanded-        v' <- typeVertex (em ! typ)-        fieldVertices v >>= mapM_ (modify . Map.alter (\ mvs -> Just (Set.insert v' (fromMaybe Set.empty mvs)))) . Set.toList+      doHint :: (Maybe Field, Name, hint) -> StateT (GraphEdges hint TypeGraphVertex) m ()+      doHint (fld, tname, hint) = hasVertexHints hint >>= mapM_ (\vh -> expandType (ConT tname) >>= allVertices fld >>= mapM_ (\v -> {-t3 v vh >>-} doVertexHint v vh)) --- | Find all the 'TypeGraphVertex' that involve this type.  All--- returned nodes will have the same set of type synonyms, but there--- will be one for each field where the type appears and one with--- field Nothing.-typeVertices :: MonadReader TypeGraphInfo m => E Type -> m (Set TypeGraphVertex)-typeVertices typ = do-  syns <- view synonyms >>= return . Map.findWithDefault Set.empty typ-  flds <- view fields >>= return . Set.insert Nothing . Set.map Just . Map.findWithDefault Set.empty typ-  return $ Set.map (\ f -> TypeGraphVertex {_etype = typ, _syns = syns, _field = f}) flds+      doVertexHint :: TypeGraphVertex -> VertexHint -> StateT (GraphEdges hint TypeGraphVertex) m ()+      doVertexHint _ Normal = return ()+      doVertexHint v Sink =+        modify $ Map.alter (alterFn (const Set.empty)) v+      doVertexHint v Hidden =+        modify $ cut (singleton v)+      -- Replace all out edges with a single edge to typ'+      doVertexHint v (Divert typ') = do+        v' <- expandType typ' >>= vertex Nothing+#if 0+        modify $ Map.alter (alterFn (const (singleton v'))) v+#else+        -- This is here because we want a path to ReportIntendedUse even+        -- though there is a substitution of String on Maybe ReportIntendedUse.+        -- I'm going to try to remove the Maybe from that substitution.+        case (null $ typeNames v) of+          False -> modify $ Map.alter (alterFn (const (singleton v'))) v+          True -> modify $ Map.alter (alterFn (Set.insert v')) v+#endif+      doVertexHint v (Extra typ') = do+        v' <- expandType typ' >>= vertex Nothing+        modify $ Map.alter (alterFn (Set.insert v')) v +      -- t1 x = trace ("before hints:\n" ++ pprint x) (return x)+      -- t2 x = trace ("after hints:\n" ++ pprint x) (return x)+      -- t3 v x = trace ("doVertexHint " ++ pprint' v ++ ": " ++ pprint x) (return ())++-- | build the function argument of Map.alter for the GraphEdges map.+alterFn :: Default hint => (Set TypeGraphVertex -> Set TypeGraphVertex) -> Maybe (hint, Set TypeGraphVertex) -> Maybe (hint, Set TypeGraphVertex)+alterFn setf (Just (hint, s)) = Just (hint, setf s)+alterFn setf Nothing | null (setf Set.empty) = Nothing+alterFn setf Nothing = Just (def, setf Set.empty)+ -- | 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.-findEdges :: forall m. (MonadReader TypeGraphInfo m) =>-             m (GraphEdges TypeGraphVertex)+findEdges :: forall hint m. (DsMonad m, Functor m, Default hint, MonadReader (TypeGraphInfo hint) m) =>+             m (GraphEdges hint TypeGraphVertex) findEdges = do-  execStateT (view typeSet >>= \ts -> mapM_ doType (Set.toList ts)) mempty+  execStateT (view typeSet >>= \ts -> mapM_ (\t -> expandType t >>= doType) ts) mempty     where-      doType :: Type -> StateT (GraphEdges TypeGraphVertex) m ()-      doType typ = view expanded >>= \em -> typeVertex (em ! typ) >>= doVertex--      doVertex :: TypeGraphVertex -> StateT (GraphEdges TypeGraphVertex) m ()-      doVertex v = do-        vs <- fieldVertices v-        mapM_ node (Set.toList vs)-        case view etype v of+      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 <- typeVertex (E typ1)-            v2 <- typeVertex (E typ2)-            mapM_ (flip edge v1) (Set.toList vs)-            mapM_ (flip edge v2) (Set.toList vs)-            doVertex v1-            doVertex v2+            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 TypeGraphVertex) m ()+      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 TypeGraphVertex) m ()+      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 TypeGraphVertex) m ()+      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 ::  Set TypeGraphVertex ->Name -> Name -> Either Int Name -> Type -> StateT (GraphEdges TypeGraphVertex) m ()+      doField ::  DsMonad m => Set TypeGraphVertex -> Name -> Name -> Either Int Name -> Type -> StateT (GraphEdges hint TypeGraphVertex) m ()       doField vs tname cname fld ftyp = do-        em <- view expanded-        v2 <- fieldVertex (em ! ftyp) (tname, cname, fld)-        mapM_ (flip edge v2) (Set.toList vs)+        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 v = modify (Map.alter (Just . maybe Set.empty id) v)-      edge v1 v2 = modify (Map.alter (Just . maybe (singleton v2) (Set.insert v2)) v1) >> node v2---- | Return the set of types embedded in the given type.  This is just--- the nodes of the type graph.  The type synonymes are expanded by the--- th-desugar package to make them suitable for use as map keys.-typeGraphVertices :: forall m. (DsMonad m, MonadReader TypeGraphInfo m) => m (Set TypeGraphVertex)-typeGraphVertices = (Set.fromList . Map.keys) <$> typeGraphEdges+      node :: TypeGraphVertex -> StateT (GraphEdges hint TypeGraphVertex) m ()+      node v = modify (Map.alter (Just . maybe (def, Set.empty) id) v) --- | Build a graph from the result of typeGraphEdges, each edge goes--- from a type to one of the types it contains.  Thus, each edge--- represents a primitive lens, and each path in the graph is a--- composition of lenses.-typeGraph :: forall m node key. (DsMonad m, MonadReader TypeGraphInfo m, node ~ TypeGraphVertex, key ~ TypeGraphVertex) =>-                m (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)-typeGraph = graphFromMap <$> typeGraphEdges+      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 :: TypeGraphEdges -> TypeGraphEdges-simpleEdges = Map.mapWithKey Set.delete . Map.mapKeys simpleVertex . Map.map (Set.map simpleVertex)+simpleEdges :: GraphEdges hint TypeGraphVertex -> GraphEdges hint TypeGraphVertex+simpleEdges = Map.mapWithKey (\v (n, s) -> (n, Set.delete v s)) .    -- delete any self edges+              Map.mapKeys simpleVertex .               -- simplify each vertex+              Map.map (over _2 (Set.map simpleVertex)) -- simplify the out edges  simpleVertex :: TypeGraphVertex -> TypeGraphVertex-simpleVertex node = node {_field = Nothing}---- | Find all the reachable type synonyms and return then in a Map.-typeSynonymMap :: forall m. (DsMonad m, MonadReader TypeGraphInfo m) => m (Map TypeGraphVertex (Set Name))-typeSynonymMap =-     (Map.filter (not . Set.null) .-      Map.fromList .-      List.map (\node -> (node, _syns node)) .-      Map.keys) <$> typeGraphEdges--typeSynonymMapSimple :: forall m. (DsMonad m, MonadReader TypeGraphInfo 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))+simpleVertex v = v {_field = Nothing}
Language/Haskell/TH/TypeGraph/Unsafe.hs view
@@ -9,14 +9,14 @@ 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.TypeGraph.Expand (Expanded(markExpanded, runExpanded'))  instance Expanded Type Type where     markExpanded = id-    runExpanded = id+    runExpanded' = id  #if !MIN_VERSION_template_haskell(2,10,0) instance Expanded Pred Pred where     markExpanded = id-    runExpanded = id+    runExpanded' = id #endif
Language/Haskell/TH/TypeGraph/Vertex.hs view
@@ -4,19 +4,23 @@     ( TypeGraphVertex(..)     , field, syns, etype     , typeNames+    , bestType+    , typeVertex -- old+    , fieldVertex -- old+    , oldVertex -- old     ) where  import Control.Lens -- (makeLenses, view)-import Data.Generics (Data, everywhere, mkT) import Data.List as List (concatMap, intersperse)-import Data.Set as Set (insert, Set, toList)+import Data.Set as Set (empty, insert, minView, Set, toList) import Language.Haskell.Exts.Syntax () import Language.Haskell.TH -- (Con, Dec, nameBase, Type)-import Language.Haskell.TH.TypeGraph.Core ()-import Language.Haskell.TH.TypeGraph.Expand (E(E), runExpanded)+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)  -- | For simple type graphs always set _field and _synonyms to Nothing. data TypeGraphVertex@@ -34,21 +38,9 @@                  _ ->   [ptext " ("] ++                         intersperse (ptext ", ")                           (List.concatMap (\ n -> [ptext ("aka " ++ show (unReifyName n))]) (Set.toList ns) ++-                           maybe [] (\ f -> [ptext (printField f)]) fld) +++                           maybe [] (\ f -> [ppr f]) fld) ++                         [ptext ")"])-        where-          printField :: (Name, Name, Either Int Name) -> String-          printField (tname, cname, field) =-              "field " ++-              show (unReifyName tname) ++ "." ++-              either (\ n -> show (unReifyName cname) ++ "[" ++ show n ++ "]") (\ f -> show (unReifyName f)) field -          unReify :: Data a => a -> a-          unReify = everywhere (mkT unReifyName)--          unReifyName :: Name -> Name-          unReifyName = mkName . nameBase- $(makeLenses ''TypeGraphVertex)  -- | Return the set of 'Name' of a type's synonyms, plus the name (if@@ -58,6 +50,19 @@ typeNames (TypeGraphVertex {_etype = E (ConT tname), _syns = s}) = Set.insert tname s typeNames (TypeGraphVertex {_syns = s}) = s +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))+ instance Lift TypeGraphVertex where     lift (TypeGraphVertex {_field = f, _syns = ns, _etype = t}) =         [|TypeGraphVertex {_field = $(lift f), _syns = $(lift ns), _etype = $(lift t)}|]++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}++-- Transitional+oldVertex :: DsMonad m => (Maybe Field, Type) -> m TypeGraphVertex+oldVertex (fld, typ) = maybe (typeVertex typ) (fieldVertex typ) fld
test/Common.hs view
@@ -1,15 +1,22 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables, TemplateHaskell #-} module Common where +import Control.Applicative ((<$>))+import Control.Monad.Reader (MonadReader, ReaderT)+import Data.Default (Default) import Data.List as List (intercalate, map)-import Data.Map as Map (Map, fromList, toList)+import Data.Map as Map (Map, filter, fromList, fromListWith, keys, toList) import Data.Monoid ((<>))-import Data.Set as Set (Set, difference, empty, fromList, null, toList)+import Data.Set as Set (Set, difference, empty, fromList, null, toList, union) import Data.Generics (Data, everywhere, mkT) import Language.Haskell.TH-import Language.Haskell.TH.TypeGraph.Core (pprint')+import Language.Haskell.TH.Desugar (DsMonad)+import Language.Haskell.TH.TypeGraph.Core (Field, pprint') import Language.Haskell.TH.TypeGraph.Expand (E, markExpanded, runExpanded)-import Language.Haskell.TH.TypeGraph.Edges (TypeGraphEdges)+import Language.Haskell.TH.TypeGraph.Graph (GraphEdges)+import Language.Haskell.TH.TypeGraph.Hints (HasVertexHints, VertexHint)+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.Syntax (Lift(lift))@@ -44,5 +51,30 @@ pprintPred :: E Pred -> String pprintPred = pprint' . unReify . runExpanded -edgesToStrings :: TypeGraphEdges -> [(String, [String])]-edgesToStrings mp = List.map (\ (t, ts) -> (pprintVertex t, map pprintVertex (Set.toList ts))) (Map.toList mp)+edgesToStrings :: GraphEdges label TypeGraphVertex -> [(String, [String])]+edgesToStrings mp = List.map (\ (t, (_, s)) -> (pprintVertex t, map pprintVertex (Set.toList s))) (Map.toList mp)++typeGraphInfo' :: DsMonad m => [(Maybe Field, Name, VertexHint)] -> [Type] -> m (TypeGraphInfo VertexHint)+typeGraphInfo' = typeGraphInfo++typeGraphEdges' :: forall m. (DsMonad m, MonadReader (TypeGraphInfo VertexHint) m) => m (GraphEdges VertexHint TypeGraphVertex)+typeGraphEdges' = typeGraphEdges++-- | 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))
test/TypeGraph.hs view
@@ -4,17 +4,21 @@ {-# OPTIONS_GHC -Wall #-} module TypeGraph where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>))+#endif import Control.Lens+import Control.Monad.Reader (runReaderT) import Data.List as List (map)-import Data.Map as Map ((!), fromList)-import Data.Set as Set (fromList, singleton, toList)+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.Expand (runExpanded, E(E))-import Language.Haskell.TH.TypeGraph.Graph (mergeVerticesM {-filterVerticesM, extendEdges, mapVerticesM-})-import Language.Haskell.TH.TypeGraph.Info (typeGraphInfo, synonyms, withTypeGraphInfo, expanded)-import Language.Haskell.TH.TypeGraph.Monad (typeGraphVertices, typeGraphEdges, typeVertex, 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.Desugar (withLocalDeclarations) import Language.Haskell.TH.Instances ()@@ -29,69 +33,69 @@ 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 -> typeGraphInfo' [] [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 -> withTypeGraphInfo [] [string] (view expanded >>= \em -> typeVertex (em ! string)) >>= lift) `shouldBe` (TypeGraphVertex Nothing (singleton ''String) (E (AppT ListT (ConT ''Char))))+     $([t|String|] >>= \string -> typeGraphInfo' [] [string] >>= runReaderT (expandType string >>= vertex Nothing) >>= lift) `shouldBe` (TypeGraphVertex Nothing (singleton ''String) (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 -> typeGraphInfo' [] [typ] >>= lift . pprint) `shouldBe` typeGraphInfoOfType    it "can find the edges of the (simplified) subtype graph of Type (typeEdges)" $ do      setDifferences (Set.fromList $(withLocalDeclarations [] $                                 runQ [t|Type|] >>= \typ ->-                                withTypeGraphInfo [] [typ] typeGraphEdges >>= return . simpleEdges >>=+                                typeGraphInfo' [] [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 ->-                                withTypeGraphInfo [] [typ] typeGraphEdges >>=+                                typeGraphInfo' [] [typ] >>= runReaderT typeGraphEdges' >>=                                 runQ . lift . edgesToStrings)) typeEdges         `shouldBe` noDifferences    it "can find the subtypesOfType" $ do      setDifferences (Set.fromList $(withLocalDeclarations [] $                                   runQ [t|Type|] >>= \typ ->-                                  withTypeGraphInfo [] [typ] typeGraphVertices >>=-                                  runQ . lift . List.map pprintVertex . Set.toList)) subtypesOfType+                                  typeGraphInfo' [] [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 ->-                                withTypeGraphInfo [] [typ] typeGraphEdges >>= return . simpleEdges >>=-                                mergeVerticesM (\ v -> (== 0) <$> (typeArity . runExpanded . _etype) v) >>=+                                typeGraphInfo' [] [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=+                                dissolveM (\ v -> (/= 0) <$> (typeArity . runExpanded . _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 ->-                                withTypeGraphInfo [] [typ] typeGraphEdges >>= return . simpleEdges >>=+                                typeGraphInfo' [] [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 ->-                                withTypeGraphInfo [] [typ] typeGraphEdges >>= return . simpleEdges >>=-                                mergeVerticesM (\ v -> (== 0) <$> (typeArity . runExpanded . _etype) v) >>=+                                typeGraphInfo' [] [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=+                                dissolveM (\ v -> (/= 0) <$> (typeArity . runExpanded . _etype) v) >>=                                 runQ . lift . edgesToStrings)) arity0DecEdges         `shouldBe` noDifferences    it "can find the subtypesOfDec" $ do      setDifferences (Set.fromList $(withLocalDeclarations [] $                                 runQ [t|Dec|] >>= \typ ->-                                withTypeGraphInfo [] [typ] typeGraphVertices >>=+                                typeGraphInfo' [] [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 ->-                                withTypeGraphInfo [] [typ] typeGraphVertices >>=+                                typeGraphInfo' [] [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@@ -100,11 +104,17 @@   it "can find the simpleSubtypesOfDec" $ do      setDifferences (Set.fromList $(withLocalDeclarations [] $                                 runQ [t|Dec|] >>= \typ ->-                                withTypeGraphInfo [] [typ] typeGraphVertices >>=+                                typeGraphInfo' [] [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 -> withTypeGraphInfo [] [typ] (typeSynonymMapSimple >>= runQ . lift)) `shouldBe` decTypeSynonyms+       runQ [t|Dec|] >>= \typ -> typeGraphInfo' [] [typ] >>= runReaderT (typeSynonymMapSimple >>= runQ . lift)) `shouldBe` decTypeSynonyms #endif++  it "can find the free type variable names in: Map k a" $ do+    $(runQ (appT (appT (conT ''Map) (varT (mkName "k"))) (varT (mkName "a"))) >>= freeTypeVars >>= runQ . lift . show) `shouldBe` "fromList [a,k]"++  it "can find the free type variable names in: Map Int String" $ do+    $(runQ [t|Map Int String|] >>= freeTypeVars  >>= runQ . lift . show) `shouldBe` "fromList []"
test/Values.hs view
@@ -11,7 +11,7 @@ import Language.Haskell.TH.TypeGraph.Core (typeArity) import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType, markExpanded) import Language.Haskell.TH.TypeGraph.Hints (VertexHint(Normal))-import Language.Haskell.TH.TypeGraph.Monad (typeGraphVertices, typeGraphEdges)+import Language.Haskell.TH.TypeGraph.Monad (typeGraphEdges) import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..)) import Language.Haskell.TH.Desugar (withLocalDeclarations) import Language.Haskell.TH.Instances ()@@ -374,121 +374,121 @@     [ #if MIN_VERSION_template_haskell(2,10,0)      ("BigNat",["ByteArray# (field BigNat.BN#[1])"]),-     ("BigNat (field Integer.Jn#[1])",["ByteArray# (field BigNat.BN#[1])"]),-     ("BigNat (field Integer.Jp#[1])",["ByteArray# (field BigNat.BN#[1])"]),+     ("BigNat (field Integer.Jn#[1])",["BigNat","ByteArray# (field BigNat.BN#[1])"]),+     ("BigNat (field Integer.Jp#[1])",["BigNat","ByteArray# (field BigNat.BN#[1])"]),      ("ByteArray#",[]),-     ("ByteArray# (field BigNat.BN#[1])",[]),+     ("ByteArray# (field BigNat.BN#[1])",["ByteArray#"]),      ("Char",["Char# (field Char.C#[1])"]),      ("Char#",[]),-     ("Char# (field Char.C#[1])",[]),+     ("Char# (field Char.C#[1])",["Char#"]),      ("Int",["Int# (field Int.I#[1])"]),-     ("Int (field NameFlavour.NameL[1])",["Int# (field Int.I#[1])"]),-     ("Int (field NameFlavour.NameU[1])",["Int# (field Int.I#[1])"]),-     ("Int (field Type.PromotedTupleT[1])",["Int# (field Int.I#[1])"]),-     ("Int (field Type.TupleT[1])",["Int# (field Int.I#[1])"]),-     ("Int (field Type.UnboxedTupleT[1])",["Int# (field Int.I#[1])"]),+     ("Int (field NameFlavour.NameL[1])",["Int","Int# (field Int.I#[1])"]),+     ("Int (field NameFlavour.NameU[1])",["Int","Int# (field Int.I#[1])"]),+     ("Int (field Type.PromotedTupleT[1])",["Int","Int# (field Int.I#[1])"]),+     ("Int (field Type.TupleT[1])",["Int","Int# (field Int.I#[1])"]),+     ("Int (field Type.UnboxedTupleT[1])",["Int","Int# (field Int.I#[1])"]),      ("Int#",[]),-     ("Int# (field Int.I#[1])",[]),-     ("Int# (field Integer.S#[1])",[]),+     ("Int# (field Int.I#[1])",["Int#"]),+     ("Int# (field Integer.S#[1])",["Int#"]),      ("Integer",["BigNat (field Integer.Jn#[1])","BigNat (field Integer.Jp#[1])","Int# (field Integer.S#[1])"]),-     ("Integer (field TyLit.NumTyLit[1])",["BigNat (field Integer.Jn#[1])","BigNat (field Integer.Jp#[1])","Int# (field Integer.S#[1])"]),+     ("Integer (field TyLit.NumTyLit[1])",["Integer","BigNat (field Integer.Jn#[1])","BigNat (field Integer.Jp#[1])","Int# (field Integer.S#[1])"]),      ("ModName",["[Char] (aka String, field ModName.ModName[1])"]),-     ("ModName (field NameFlavour.NameG[3])",["[Char] (aka String, field ModName.ModName[1])"]),-     ("ModName (field NameFlavour.NameQ[1])",["[Char] (aka String, field ModName.ModName[1])"]),+     ("ModName (field NameFlavour.NameG[3])",["ModName","[Char] (aka String, field ModName.ModName[1])"]),+     ("ModName (field NameFlavour.NameQ[1])",["ModName","[Char] (aka String, field ModName.ModName[1])"]),      ("Name",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),-     ("Name (field TyVarBndr.KindedTV[1])",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),-     ("Name (field TyVarBndr.PlainTV[1])",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),-     ("Name (field Type.ConT[1])",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),-     ("Name (field Type.PromotedT[1])",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),-     ("Name (field Type.VarT[1])",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),+     ("Name (field TyVarBndr.KindedTV[1])",["Name","OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),+     ("Name (field TyVarBndr.PlainTV[1])",["Name","OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),+     ("Name (field Type.ConT[1])",["Name","OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),+     ("Name (field Type.PromotedT[1])",["Name","OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),+     ("Name (field Type.VarT[1])",["Name","OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),      ("NameFlavour",["NameSpace (field NameFlavour.NameG[1])","PkgName (field NameFlavour.NameG[2])","ModName (field NameFlavour.NameG[3])","Int (field NameFlavour.NameL[1])","ModName (field NameFlavour.NameQ[1])","Int (field NameFlavour.NameU[1])"]),-     ("NameFlavour (field Name.Name[2])",["NameSpace (field NameFlavour.NameG[1])","PkgName (field NameFlavour.NameG[2])","ModName (field NameFlavour.NameG[3])","Int (field NameFlavour.NameL[1])","ModName (field NameFlavour.NameQ[1])","Int (field NameFlavour.NameU[1])"]),+     ("NameFlavour (field Name.Name[2])",["NameFlavour","NameSpace (field NameFlavour.NameG[1])","PkgName (field NameFlavour.NameG[2])","ModName (field NameFlavour.NameG[3])","Int (field NameFlavour.NameL[1])","ModName (field NameFlavour.NameQ[1])","Int (field NameFlavour.NameU[1])"]),      ("NameSpace",[]),-     ("NameSpace (field NameFlavour.NameG[1])",[]),+     ("NameSpace (field NameFlavour.NameG[1])",["NameSpace"]),      ("OccName",["[Char] (aka String, field OccName.OccName[1])"]),-     ("OccName (field Name.Name[1])",["[Char] (aka String, field OccName.OccName[1])"]),+     ("OccName (field Name.Name[1])",["OccName","[Char] (aka String, field OccName.OccName[1])"]),      ("PkgName",["[Char] (aka String, field PkgName.PkgName[1])"]),-     ("PkgName (field NameFlavour.NameG[2])",["[Char] (aka String, field PkgName.PkgName[1])"]),+     ("PkgName (field NameFlavour.NameG[2])",["PkgName","[Char] (aka String, field PkgName.PkgName[1])"]),      ("TyLit",["Integer (field TyLit.NumTyLit[1])","[Char] (aka String, field TyLit.StrTyLit[1])"]),-     ("TyLit (field Type.LitT[1])",["Integer (field TyLit.NumTyLit[1])","[Char] (aka String, field TyLit.StrTyLit[1])"]),+     ("TyLit (field Type.LitT[1])",["TyLit","Integer (field TyLit.NumTyLit[1])","[Char] (aka String, field TyLit.StrTyLit[1])"]),      ("TyVarBndr",["Name (field TyVarBndr.KindedTV[1])","Type (aka Kind, aka Pred, field TyVarBndr.KindedTV[2])","Name (field TyVarBndr.PlainTV[1])"]),      ("Type (aka Kind, aka Pred)",["Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, aka Pred, field TyVarBndr.KindedTV[2])",["Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, aka Pred, field Type.AppT[1])",["Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, aka Pred, field Type.AppT[2])",["Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, aka Pred, field Type.ForallT[3])",["Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, aka Pred, field Type.SigT[1])",["Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, aka Pred, field Type.SigT[2])",["Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, aka Pred, field TyVarBndr.KindedTV[2])",["Type (aka Kind, aka Pred)","Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, aka Pred, field Type.AppT[1])",["Type (aka Kind, aka Pred)","Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, aka Pred, field Type.AppT[2])",["Type (aka Kind, aka Pred)","Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, aka Pred, field Type.ForallT[3])",["Type (aka Kind, aka Pred)","Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, aka Pred, field Type.SigT[1])",["Type (aka Kind, aka Pred)","Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, aka Pred, field Type.SigT[2])",["Type (aka Kind, aka Pred)","Type (aka Kind, aka Pred, field Type.AppT[1])","Type (aka Kind, aka Pred, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Type] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, aka Pred, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, aka Pred, field Type.SigT[1])","Type (aka Kind, aka Pred, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),      ("[Char] (aka String)",["Char","[]"]),-     ("[Char] (aka String, field ModName.ModName[1])",["Char","[]"]),-     ("[Char] (aka String, field OccName.OccName[1])",["Char","[]"]),-     ("[Char] (aka String, field PkgName.PkgName[1])",["Char","[]"]),-     ("[Char] (aka String, field TyLit.StrTyLit[1])",["Char","[]"]),+     ("[Char] (aka String, field ModName.ModName[1])",["Char","[]","[Char] (aka String)"]),+     ("[Char] (aka String, field OccName.OccName[1])",["Char","[]","[Char] (aka String)"]),+     ("[Char] (aka String, field PkgName.PkgName[1])",["Char","[]","[Char] (aka String)"]),+     ("[Char] (aka String, field TyLit.StrTyLit[1])",["Char","[]","[Char] (aka String)"]),      ("[TyVarBndr]",["TyVarBndr","[]"]),-     ("[TyVarBndr] (field Type.ForallT[1])",["TyVarBndr","[]"]),+     ("[TyVarBndr] (field Type.ForallT[1])",["[TyVarBndr]","TyVarBndr","[]"]),      ("[Type] (aka Cxt)",["[]","Type (aka Kind, aka Pred)"]),-     ("[Type] (aka Cxt, field Type.ForallT[2])",["[]","Type (aka Kind, aka Pred)"]),+     ("[Type] (aka Cxt, field Type.ForallT[2])",["[]","[Type] (aka Cxt)","Type (aka Kind, aka Pred)"]),      ("[]",[]) #else      ("ByteArray#",[]),-     ("ByteArray# (field Integer.J#[2])",[]),+     ("ByteArray# (field Integer.J#[2])",["ByteArray#"]),      ("Char",["Char# (field Char.C#[1])"]),      ("Char#",[]),-     ("Char# (field Char.C#[1])",[]),+     ("Char# (field Char.C#[1])",["Char#"]),      ("Int",["Int# (field Int.I#[1])"]),-     ("Int (field Type.PromotedTupleT[1])",["Int# (field Int.I#[1])"]),-     ("Int (field Type.TupleT[1])",["Int# (field Int.I#[1])"]),-     ("Int (field Type.UnboxedTupleT[1])",["Int# (field Int.I#[1])"]),+     ("Int (field Type.PromotedTupleT[1])",["Int","Int# (field Int.I#[1])"]),+     ("Int (field Type.TupleT[1])",["Int","Int# (field Int.I#[1])"]),+     ("Int (field Type.UnboxedTupleT[1])",["Int","Int# (field Int.I#[1])"]),      ("Int#",[]),-     ("Int# (field Int.I#[1])",[]),-     ("Int# (field Integer.J#[1])",[]),-     ("Int# (field Integer.S#[1])",[]),-     ("Int# (field NameFlavour.NameL[1])",[]),-     ("Int# (field NameFlavour.NameU[1])",[]),+     ("Int# (field Int.I#[1])",["Int#"]),+     ("Int# (field Integer.J#[1])",["Int#"]),+     ("Int# (field Integer.S#[1])",["Int#"]),+     ("Int# (field NameFlavour.NameL[1])",["Int#"]),+     ("Int# (field NameFlavour.NameU[1])",["Int#"]),      ("Integer",["Int# (field Integer.J#[1])","ByteArray# (field Integer.J#[2])","Int# (field Integer.S#[1])"]),-     ("Integer (field TyLit.NumTyLit[1])",["Int# (field Integer.J#[1])","ByteArray# (field Integer.J#[2])","Int# (field Integer.S#[1])"]),+     ("Integer (field TyLit.NumTyLit[1])",["Integer","Int# (field Integer.J#[1])","ByteArray# (field Integer.J#[2])","Int# (field Integer.S#[1])"]),      ("ModName",["[Char] (aka String, field ModName.ModName[1])"]),-     ("ModName (field NameFlavour.NameG[3])",["[Char] (aka String, field ModName.ModName[1])"]),-     ("ModName (field NameFlavour.NameQ[1])",["[Char] (aka String, field ModName.ModName[1])"]),+     ("ModName (field NameFlavour.NameG[3])",["ModName","[Char] (aka String, field ModName.ModName[1])"]),+     ("ModName (field NameFlavour.NameQ[1])",["ModName","[Char] (aka String, field ModName.ModName[1])"]),      ("Name",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),-     ("Name (field Pred.ClassP[1])",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),-     ("Name (field TyVarBndr.KindedTV[1])",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),-     ("Name (field TyVarBndr.PlainTV[1])",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),-     ("Name (field Type.ConT[1])",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),-     ("Name (field Type.PromotedT[1])",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),-     ("Name (field Type.VarT[1])",["OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),+     ("Name (field Pred.ClassP[1])",["Name","OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),+     ("Name (field TyVarBndr.KindedTV[1])",["Name","OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),+     ("Name (field TyVarBndr.PlainTV[1])",["Name","OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),+     ("Name (field Type.ConT[1])",["Name","OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),+     ("Name (field Type.PromotedT[1])",["Name","OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),+     ("Name (field Type.VarT[1])",["Name","OccName (field Name.Name[1])","NameFlavour (field Name.Name[2])"]),      ("NameFlavour",["NameSpace (field NameFlavour.NameG[1])","PkgName (field NameFlavour.NameG[2])","ModName (field NameFlavour.NameG[3])","Int# (field NameFlavour.NameL[1])","ModName (field NameFlavour.NameQ[1])","Int# (field NameFlavour.NameU[1])"]),-     ("NameFlavour (field Name.Name[2])",["NameSpace (field NameFlavour.NameG[1])","PkgName (field NameFlavour.NameG[2])","ModName (field NameFlavour.NameG[3])","Int# (field NameFlavour.NameL[1])","ModName (field NameFlavour.NameQ[1])","Int# (field NameFlavour.NameU[1])"]),+     ("NameFlavour (field Name.Name[2])",["NameFlavour","NameSpace (field NameFlavour.NameG[1])","PkgName (field NameFlavour.NameG[2])","ModName (field NameFlavour.NameG[3])","Int# (field NameFlavour.NameL[1])","ModName (field NameFlavour.NameQ[1])","Int# (field NameFlavour.NameU[1])"]),      ("NameSpace",[]),-     ("NameSpace (field NameFlavour.NameG[1])",[]),+     ("NameSpace (field NameFlavour.NameG[1])",["NameSpace"]),      ("OccName",["[Char] (aka String, field OccName.OccName[1])"]),-     ("OccName (field Name.Name[1])",["[Char] (aka String, field OccName.OccName[1])"]),+     ("OccName (field Name.Name[1])",["OccName","[Char] (aka String, field OccName.OccName[1])"]),      ("PkgName",["[Char] (aka String, field PkgName.PkgName[1])"]),-     ("PkgName (field NameFlavour.NameG[2])",["[Char] (aka String, field PkgName.PkgName[1])"]),+     ("PkgName (field NameFlavour.NameG[2])",["PkgName","[Char] (aka String, field PkgName.PkgName[1])"]),      ("Pred",["Name (field Pred.ClassP[1])","[Type] (field Pred.ClassP[2])","Type (aka Kind, field Pred.EqualP[1])","Type (aka Kind, field Pred.EqualP[2])"]),      ("TyLit",["Integer (field TyLit.NumTyLit[1])","[Char] (aka String, field TyLit.StrTyLit[1])"]),-     ("TyLit (field Type.LitT[1])",["Integer (field TyLit.NumTyLit[1])","[Char] (aka String, field TyLit.StrTyLit[1])"]),+     ("TyLit (field Type.LitT[1])",["TyLit","Integer (field TyLit.NumTyLit[1])","[Char] (aka String, field TyLit.StrTyLit[1])"]),      ("TyVarBndr",["Name (field TyVarBndr.KindedTV[1])","Type (aka Kind, field TyVarBndr.KindedTV[2])","Name (field TyVarBndr.PlainTV[1])"]),      ("Type (aka Kind)",["Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, field Pred.EqualP[1])",["Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, field Pred.EqualP[2])",["Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, field TyVarBndr.KindedTV[2])",["Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, field Type.AppT[1])",["Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, field Type.AppT[2])",["Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, field Type.ForallT[3])",["Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, field Type.SigT[1])",["Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),-     ("Type (aka Kind, field Type.SigT[2])",["Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, field Pred.EqualP[1])",["Type (aka Kind)","Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, field Pred.EqualP[2])",["Type (aka Kind)","Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, field TyVarBndr.KindedTV[2])",["Type (aka Kind)","Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, field Type.AppT[1])",["Type (aka Kind)","Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, field Type.AppT[2])",["Type (aka Kind)","Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, field Type.ForallT[3])",["Type (aka Kind)","Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, field Type.SigT[1])",["Type (aka Kind)","Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),+     ("Type (aka Kind, field Type.SigT[2])",["Type (aka Kind)","Type (aka Kind, field Type.AppT[1])","Type (aka Kind, field Type.AppT[2])","Name (field Type.ConT[1])","[TyVarBndr] (field Type.ForallT[1])","[Pred] (aka Cxt, field Type.ForallT[2])","Type (aka Kind, field Type.ForallT[3])","TyLit (field Type.LitT[1])","Name (field Type.PromotedT[1])","Int (field Type.PromotedTupleT[1])","Type (aka Kind, field Type.SigT[1])","Type (aka Kind, field Type.SigT[2])","Int (field Type.TupleT[1])","Int (field Type.UnboxedTupleT[1])","Name (field Type.VarT[1])"]),      ("[Char] (aka String)",["Char","[]"]),-     ("[Char] (aka String, field ModName.ModName[1])",["Char","[]"]),-     ("[Char] (aka String, field OccName.OccName[1])",["Char","[]"]),-     ("[Char] (aka String, field PkgName.PkgName[1])",["Char","[]"]),-     ("[Char] (aka String, field TyLit.StrTyLit[1])",["Char","[]"]),+     ("[Char] (aka String, field ModName.ModName[1])",["Char","[]","[Char] (aka String)"]),+     ("[Char] (aka String, field OccName.OccName[1])",["Char","[]","[Char] (aka String)"]),+     ("[Char] (aka String, field PkgName.PkgName[1])",["Char","[]","[Char] (aka String)"]),+     ("[Char] (aka String, field TyLit.StrTyLit[1])",["Char","[]","[Char] (aka String)"]),      ("[Pred] (aka Cxt)",["Pred","[]"]),-     ("[Pred] (aka Cxt, field Type.ForallT[2])",["Pred","[]"]),+     ("[Pred] (aka Cxt, field Type.ForallT[2])",["Pred","[]","[Pred] (aka Cxt)"]),      ("[TyVarBndr]",["TyVarBndr","[]"]),-     ("[TyVarBndr] (field Type.ForallT[1])",["TyVarBndr","[]"]),+     ("[TyVarBndr] (field Type.ForallT[1])",["[TyVarBndr]","TyVarBndr","[]"]),      ("[Type]",["[]","Type (aka Kind)"]),-     ("[Type] (field Pred.ClassP[2])",["[]","Type (aka Kind)"]),+     ("[Type] (field Pred.ClassP[2])",["[Type]","[]","Type (aka Kind)"]),      ("[]",[]) #endif     ]@@ -1072,27 +1072,27 @@   Set.fromList     ["instance IArray UArray (FunPtr a)","instance IArray UArray (Ptr a)","instance IArray UArray (StablePtr a)","instance IArray UArray Bool","instance IArray UArray Char","instance IArray UArray Double","instance IArray UArray Float","instance IArray UArray Int","instance IArray UArray Int16","instance IArray UArray Int32","instance IArray UArray Int64","instance IArray UArray Int8","instance IArray UArray Word","instance IArray UArray Word16","instance IArray UArray Word32","instance IArray UArray Word64","instance IArray UArray Word8"] -decTypeSynonyms :: Map (E Type) (Set Name)+decTypeSynonyms :: Map (E Type) ((), Set Name) decTypeSynonyms =   Map.fromList     [ #if MIN_VERSION_template_haskell(2,10,0)-     (E (AppT (AppT (AppT (TupleT 3) (ConT ''Name)) (ConT ''Strict)) (ConT ''Type)), Set.fromList [''VarStrictType]),-     (E (AppT (AppT (TupleT 2) (ConT ''Name)) (ConT ''Exp)),                         Set.fromList [''FieldExp]),-     (E (AppT (AppT (TupleT 2) (ConT ''Name)) (ConT ''Pat)),                         Set.fromList [''FieldPat]),-     (E (AppT (AppT (TupleT 2) (ConT ''Strict)) (ConT ''Type)),                      Set.fromList [''StrictType]),-     (E (AppT (ConT ''Ratio) (ConT ''Integer)),                                      Set.fromList [''Rational]),-     (E (AppT ListT (ConT ''Char)),                                                  Set.fromList [''String]),-     (E (AppT ListT (ConT ''Type)),                                                  Set.fromList [''Cxt]),-     (E (ConT ''Type),                                                               Set.fromList [''Kind,''Pred])+     (E (AppT (AppT (AppT (TupleT 3) (ConT ''Name)) (ConT ''Strict)) (ConT ''Type)), ((), Set.fromList [''VarStrictType])),+     (E (AppT (AppT (TupleT 2) (ConT ''Name)) (ConT ''Exp)),                         ((), Set.fromList [''FieldExp])),+     (E (AppT (AppT (TupleT 2) (ConT ''Name)) (ConT ''Pat)),                         ((), Set.fromList [''FieldPat])),+     (E (AppT (AppT (TupleT 2) (ConT ''Strict)) (ConT ''Type)),                      ((), Set.fromList [''StrictType])),+     (E (AppT (ConT ''Ratio) (ConT ''Integer)),                                      ((), Set.fromList [''Rational])),+     (E (AppT ListT (ConT ''Char)),                                                  ((), Set.fromList [''String])),+     (E (AppT ListT (ConT ''Type)),                                                  ((), Set.fromList [''Cxt])),+     (E (ConT ''Type),                                                               ((), Set.fromList [''Kind,''Pred])) #else-     (E (AppT (AppT (AppT (TupleT 3) (ConT ''Name)) (ConT ''Strict)) (ConT ''Type)), Set.fromList [''VarStrictType]),-     (E (AppT (AppT (TupleT 2) (ConT ''Name)) (ConT ''Exp)),                         Set.fromList [''FieldExp]),-     (E (AppT (AppT (TupleT 2) (ConT ''Name)) (ConT ''Pat)),                         Set.fromList [''FieldPat]),-     (E (AppT (AppT (TupleT 2) (ConT ''Strict)) (ConT ''Type)),                      Set.fromList [''StrictType]),-     (E (AppT (ConT ''Ratio) (ConT ''Integer)),                                      Set.fromList [''Rational]),-     (E (AppT ListT (ConT ''Char)),                                                  Set.fromList [''String]),-     (E (AppT ListT (ConT ''Pred)),                                                  Set.fromList [''Cxt]),-     (E (ConT ''Type),                                                               Set.fromList [''Kind])+     (E (AppT (AppT (AppT (TupleT 3) (ConT ''Name)) (ConT ''Strict)) (ConT ''Type)), ((), Set.fromList [''VarStrictType])),+     (E (AppT (AppT (TupleT 2) (ConT ''Name)) (ConT ''Exp)),                         ((), Set.fromList [''FieldExp])),+     (E (AppT (AppT (TupleT 2) (ConT ''Name)) (ConT ''Pat)),                         ((), Set.fromList [''FieldPat])),+     (E (AppT (AppT (TupleT 2) (ConT ''Strict)) (ConT ''Type)),                      ((), Set.fromList [''StrictType])),+     (E (AppT (ConT ''Ratio) (ConT ''Integer)),                                      ((), Set.fromList [''Rational])),+     (E (AppT ListT (ConT ''Char)),                                                  ((), Set.fromList [''String])),+     (E (AppT ListT (ConT ''Pred)),                                                  ((), Set.fromList [''Cxt])),+     (E (ConT ''Type),                                                               ((), Set.fromList [''Kind])) #endif     ]
th-typegraph.cabal view
@@ -1,5 +1,5 @@ name:               th-typegraph-version:            0.14+version:            0.17 cabal-version:      >= 1.10 build-type:         Simple license:            BSD3@@ -31,8 +31,8 @@   ghc-options:      -Wall   exposed-modules:  Language.Haskell.TH.TypeGraph                     Language.Haskell.TH.TypeGraph.Core-                    Language.Haskell.TH.TypeGraph.Edges                     Language.Haskell.TH.TypeGraph.Expand+                    Language.Haskell.TH.TypeGraph.Free                     Language.Haskell.TH.TypeGraph.Graph                     Language.Haskell.TH.TypeGraph.Hints                     Language.Haskell.TH.TypeGraph.Info@@ -45,7 +45,7 @@   type:             exitcode-stdio-1.0   hs-source-dirs:   test   main-is:          Tests.hs-  build-depends:    array, base, bytestring, containers, deepseq, ghc-prim,+  build-depends:    array, base, bytestring, containers, data-default, deepseq, ghc-prim,                     hspec, hspec-core, lens, mtl, syb, template-haskell, text,                     th-typegraph, th-desugar, th-orphans, th-reify-many   default-language: Haskell2010