th-typegraph 0.17.1 → 0.18
raw patch · 9 files changed
+61/−139 lines, 9 files
Files
- Language/Haskell/TH/TypeGraph.hs +1/−3
- Language/Haskell/TH/TypeGraph/Graph.hs +12/−12
- Language/Haskell/TH/TypeGraph/Hints.hs +0/−56
- Language/Haskell/TH/TypeGraph/Info.hs +20/−35
- Language/Haskell/TH/TypeGraph/Monad.hs +6/−6
- test/Common.hs +6/−7
- test/TypeGraph.hs +13/−13
- test/Values.hs +2/−5
- th-typegraph.cabal +1/−2
Language/Haskell/TH/TypeGraph.hs view
@@ -2,7 +2,6 @@ ( module Language.Haskell.TH.TypeGraph.Core , module Language.Haskell.TH.TypeGraph.Expand , module Language.Haskell.TH.TypeGraph.Graph- , module Language.Haskell.TH.TypeGraph.Hints , module Language.Haskell.TH.TypeGraph.Info , module Language.Haskell.TH.TypeGraph.Monad -- , module Language.Haskell.TH.TypeGraph.Unsafe@@ -12,8 +11,7 @@ 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, Divert, Extra))-import Language.Haskell.TH.TypeGraph.Info (TypeGraphInfo, fields, hints, infoMap, synonyms, typeSet,+import Language.Haskell.TH.TypeGraph.Info (TypeGraphInfo, fields, infoMap, synonyms, typeSet, emptyTypeGraphInfo, typeGraphInfo) import Language.Haskell.TH.TypeGraph.Monad (vertex, allVertices, typeGraphEdges, simpleEdges, simpleVertex) import Language.Haskell.TH.TypeGraph.Unsafe ()
Language/Haskell/TH/TypeGraph/Graph.hs view
@@ -35,9 +35,9 @@ import Language.Haskell.TH.TypeGraph.Core (pprint') import Prelude hiding (foldr) -type GraphEdges label key = Map key (label, Set key)+type GraphEdges node key = Map key (node, Set key) -instance Ppr key => Ppr (GraphEdges label key) where+instance Ppr key => Ppr (GraphEdges node key) where ppr x = ptext $ intercalate "\n " $ "edges:" : (List.map@@ -48,26 +48,26 @@ -- 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 label key. (Ord key) =>- GraphEdges label key -> (Graph, Vertex -> (label, key, [key]), key -> Maybe Vertex)+graphFromMap :: forall node key. (Ord key) =>+ GraphEdges node key -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) graphFromMap mp = graphFromEdges triples where- triples :: [(label, key, [key])]+ triples :: [(node, 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 :: (Eq a, Ord a) => Set a -> GraphEdges node a -> GraphEdges node a cut victims edges = Map.filterWithKey (\v _ -> not (Set.member v victims)) (isolate victims edges) -- | 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 :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges node a -> m (GraphEdges node a) cutM victim edges = do victims <- Set.fromList <$> filterM victim (Map.keys edges) return $ cut victims edges -- | Remove all the in- and out-edges of some nodes-isolate :: (Eq a, Ord a) => Set a -> GraphEdges label a -> GraphEdges label a+isolate :: (Eq a, Ord a) => Set a -> GraphEdges node a -> GraphEdges node a isolate victims edges = edges'' where@@ -75,17 +75,17 @@ 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 :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges node a -> m (GraphEdges node a) isolateM victim edges = do victims <- Set.fromList <$> filterM victim (Map.keys edges) return $ isolate victims edges -- | 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 :: (Eq a, Ord a) => Set a -> GraphEdges node a -> GraphEdges node a dissolve victims edges0 = foldr dissolve1 edges0 victims where- dissolve1 :: (Eq a, Ord a) => a -> GraphEdges label a -> GraphEdges label a+ dissolve1 :: (Eq a, Ord a) => a -> GraphEdges node a -> GraphEdges node a dissolve1 victim edges = -- Wherever the victim vertex appears as an out-edge, substitute the vOut set Map.mapWithKey (\k (h, s) -> (h, extend k s)) survivorEdges@@ -98,7 +98,7 @@ (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 :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges node a -> m (GraphEdges node a) dissolveM victim edges = do victims <- Set.fromList <$> filterM victim (Map.keys edges) return $ dissolve victims edges
− Language/Haskell/TH/TypeGraph/Hints.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_GHC -Wall #-}-module Language.Haskell.TH.TypeGraph.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))---- | 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- | 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- def = Normal--instance Lift VertexHint where- lift Normal = [|Normal|]- lift (Divert x) = [|Divert $(lift x)|]- lift (Extra x) = [|Extra $(lift x)|]--instance Ppr VertexHint where- ppr Normal = ptext "Normal"- 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,7 +13,7 @@ ( TypeGraphInfo , emptyTypeGraphInfo , typeGraphInfo- , fields, hints, infoMap, synonyms, typeSet+ , fields, infoMap, synonyms, typeSet ) where #if __GLASGOW_HASKELL__ < 709@@ -26,9 +26,8 @@ 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 (Field, pprint')+import Language.Haskell.TH.TypeGraph.Core (pprint') import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)-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)@@ -36,7 +35,7 @@ -- | Information collected about the graph implied by the structure of -- one or more 'Type' values.-data TypeGraphInfo hint+data TypeGraphInfo = TypeGraphInfo { _typeSet :: Set Type -- ^ All the types encountered, including embedded types such as the@@ -49,46 +48,39 @@ -- ^ The types with all type synonyms replaced with their expansions. , _fields :: Map (E Type) (Set (Name, Name, Either Int Name)) -- ^ 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 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"+instance Ppr TypeGraphInfo where+ ppr (TypeGraphInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f}) =+ ptext $ intercalate "\n " ["TypeGraphInfo:", ppt, ppi, ppe, pps, ppf] ++ "\n" 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 . (\ (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) -instance Lift hint => Lift (TypeGraphInfo hint) where- lift (TypeGraphInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f, _hints = h}) =+instance Lift TypeGraphInfo where+ lift (TypeGraphInfo {_typeSet = t, _infoMap = i, _expanded = e, _synonyms = s, _fields = f}) = [| TypeGraphInfo { _typeSet = $(lift t) , _infoMap = $(lift i) , _expanded = $(lift e) , _synonyms = $(lift s) , _fields = $(lift f)- , _hints = $(lift h) } |] -emptyTypeGraphInfo :: TypeGraphInfo hint-emptyTypeGraphInfo = TypeGraphInfo {_typeSet = mempty, _infoMap = mempty, _expanded = mempty, _synonyms = mempty, _fields = mempty, _hints = mempty}+emptyTypeGraphInfo :: TypeGraphInfo+emptyTypeGraphInfo = TypeGraphInfo {_typeSet = mempty, _infoMap = mempty, _expanded = mempty, _synonyms = mempty, _fields = mempty} -- | 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 :: forall m. DsMonad m => Type -> StateT TypeGraphInfo m () collectTypeInfo typ0 = do doType typ0 where- doType :: Type -> StateT (TypeGraphInfo hint) m ()+ doType :: Type -> StateT TypeGraphInfo m () doType typ = do (s :: Set Type) <- use typeSet case Set.member typ s of@@ -99,7 +91,7 @@ -- expanded %= Map.insert etyp' etyp -- A type is its own expansion, but we shouldn't need this doType' typ - doType' :: Type -> StateT (TypeGraphInfo hint) m ()+ doType' :: Type -> StateT TypeGraphInfo m () doType' (ConT name) = do info <- qReify name infoMap %= Map.insert name info@@ -110,13 +102,13 @@ doType' (TupleT _) = return () doType' typ = error $ "typeGraphInfo: " ++ pprint' typ - doInfo :: Name -> Info -> StateT (TypeGraphInfo hint) m ()+ doInfo :: Name -> Info -> StateT TypeGraphInfo 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 hint) m ()+ doDec :: Dec -> StateT TypeGraphInfo m () doDec (TySynD tname _ typ) = do etyp <- expandType (ConT tname) synonyms %= Map.insertWith union etyp (singleton tname)@@ -125,25 +117,18 @@ doDec (DataD _ tname _ constrs _) = mapM_ (doCon tname) constrs doDec dec = error $ "typeGraphInfo: " ++ pprint' dec - doCon :: Name -> Con -> StateT (TypeGraphInfo hint) m ()+ doCon :: Name -> Con -> StateT TypeGraphInfo 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 hint) m ()+ doField :: ((Name, Name, Either Int Name), Type) -> StateT TypeGraphInfo m () doField (fld, ftyp) = do etyp <- expandType ftyp fields %= Map.insertWith union etyp (singleton fld) doType ftyp --- | 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)])---- | 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+-- | Build a TypeGraphInfo value by scanning the supplied types+typeGraphInfo :: forall m. DsMonad m => [Type] -> m TypeGraphInfo+typeGraphInfo types = flip execStateT emptyTypeGraphInfo $ mapM_ collectTypeInfo types
Language/Haskell/TH/TypeGraph/Monad.hs view
@@ -46,7 +46,7 @@ import Language.Haskell.TH.Instances () import Prelude hiding (foldr, mapM_, null) -allVertices :: (Functor m, DsMonad m, MonadReader (TypeGraphInfo hint) m) =>+allVertices :: (Functor m, DsMonad m, MonadReader TypeGraphInfo m) => Maybe Field -> E Type -> m (Set TypeGraphVertex) allVertices (Just fld) etyp = singleton <$> vertex (Just fld) etyp allVertices Nothing etyp = vertex Nothing etyp >>= \v -> fieldVertices v >>= \vs -> return $ Set.insert v vs@@ -55,31 +55,31 @@ -- 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 :: MonadReader TypeGraphInfo m => TypeGraphVertex -> m (Set TypeGraphVertex) fieldVertices v = do fm <- view fields let fs = Map.findWithDefault Set.empty (view etype v) fm return $ Set.map (\fld' -> set field (Just fld') v) fs -- | Build a vertex from the given 'Type' and optional 'Field'.-vertex :: forall m hint. (DsMonad m, MonadReader (TypeGraphInfo hint) m) => Maybe Field -> E Type -> m TypeGraphVertex+vertex :: forall m. (DsMonad m, MonadReader TypeGraphInfo m) => Maybe Field -> E Type -> m TypeGraphVertex vertex fld etyp = maybe (typeVertex etyp) (fieldVertex etyp) fld -- | Build a non-field vertex-typeVertex :: MonadReader (TypeGraphInfo hint) m => E Type -> m TypeGraphVertex+typeVertex :: MonadReader TypeGraphInfo m => E Type -> m TypeGraphVertex typeVertex etyp = do sm <- view synonyms return $ TypeGraphVertex {_field = Nothing, _syns = Map.findWithDefault Set.empty etyp sm, _etype = etyp} -- | Build a vertex associated with a field-fieldVertex :: MonadReader (TypeGraphInfo hint) m => E Type -> Field -> m TypeGraphVertex+fieldVertex :: MonadReader TypeGraphInfo m => E Type -> Field -> m TypeGraphVertex fieldVertex etyp fld' = typeVertex etyp >>= \v -> return $ v {_field = Just fld'} -- | Given the discovered set of types and maps of type synonyms and -- fields, build and return the GraphEdges relation on TypeGraphVertex. -- This is not a recursive function, it stops when it reaches the field -- types.-typeGraphEdges :: forall hint m. (DsMonad m, Functor m, Default hint, MonadReader (TypeGraphInfo hint) m) =>+typeGraphEdges :: forall hint m. (DsMonad m, Functor m, Default hint, MonadReader TypeGraphInfo m) => m (GraphEdges hint TypeGraphVertex) typeGraphEdges = do execStateT (view typeSet >>= \ts -> mapM_ (\t -> expandType t >>= doType) ts) mempty
test/Common.hs view
@@ -6,7 +6,7 @@ import Data.Default (Default) import Data.List as List (intercalate, map) import Data.Map as Map (Map, filter, fromList, fromListWith, keys, toList)-import Data.Monoid ((<>))+import Data.Monoid ((<>), Monoid(mempty, mappend)) import Data.Set as Set (Set, difference, empty, fromList, null, toList, union) import Data.Generics (Data, everywhere, mkT) import Language.Haskell.TH@@ -14,7 +14,6 @@ import Language.Haskell.TH.TypeGraph.Core (Field, pprint') import Language.Haskell.TH.TypeGraph.Expand (E, markExpanded, runExpanded) 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(..))@@ -54,24 +53,24 @@ 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' :: DsMonad m => [Type] -> m TypeGraphInfo typeGraphInfo' = typeGraphInfo -typeGraphEdges' :: forall m. (DsMonad m, MonadReader (TypeGraphInfo VertexHint) m) => m (GraphEdges VertexHint TypeGraphVertex)+typeGraphEdges' :: forall m. (DsMonad m, MonadReader TypeGraphInfo m) => m (GraphEdges () 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) =>+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+ Map.keys) <$> (typeGraphEdges :: m (GraphEdges () TypeGraphVertex)) -- | Like 'typeSynonymMap', but with all field information removed.-typeSynonymMapSimple :: forall m hint. (DsMonad m, Default hint, Eq hint, HasVertexHints hint, MonadReader (TypeGraphInfo hint) m) =>+typeSynonymMapSimple :: forall m. (DsMonad m, MonadReader TypeGraphInfo m) => m (Map (E Type) (Set Name)) typeSynonymMapSimple = simplify <$> typeSynonymMap
test/TypeGraph.hs view
@@ -33,39 +33,39 @@ 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 -> typeGraphInfo' [] [string] >>= runReaderT (expandType string >>= vertex Nothing) >>= 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 ->- typeGraphInfo' [] [typ] >>= runReaderT 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 ->- typeGraphInfo' [] [typ] >>= runReaderT 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 ->- typeGraphInfo' [] [typ] >>= runReaderT typeGraphEdges' >>=+ 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 ->- typeGraphInfo' [] [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=+ typeGraphInfo' [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>= dissolveM (\ v -> (/= 0) <$> (typeArity . runExpanded . _etype) v) >>= runQ . lift . edgesToStrings)) arity0TypeEdges `shouldBe` noDifferences@@ -73,14 +73,14 @@ it "can find the edges of the simple subtype graph of Dec (decEdges)" $ do setDifferences (Set.fromList $(withLocalDeclarations [] $ runQ [t|Dec|] >>= \typ ->- typeGraphInfo' [] [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=+ 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 ->- typeGraphInfo' [] [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>=+ typeGraphInfo' [typ] >>= runReaderT typeGraphEdges' >>= return . simpleEdges >>= dissolveM (\ v -> (/= 0) <$> (typeArity . runExpanded . _etype) v) >>= runQ . lift . edgesToStrings)) arity0DecEdges `shouldBe` noDifferences@@ -88,14 +88,14 @@ it "can find the subtypesOfDec" $ do setDifferences (Set.fromList $(withLocalDeclarations [] $ runQ [t|Dec|] >>= \typ ->- typeGraphInfo' [] [typ] >>= runReaderT 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 ->- typeGraphInfo' [] [typ] >>= runReaderT 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@@ -104,13 +104,13 @@ it "can find the simpleSubtypesOfDec" $ do setDifferences (Set.fromList $(withLocalDeclarations [] $ runQ [t|Dec|] >>= \typ ->- typeGraphInfo' [] [typ] >>= runReaderT 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 -> typeGraphInfo' [] [typ] >>= runReaderT (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
test/Values.hs view
@@ -10,7 +10,6 @@ import Language.Haskell.TH 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 (typeGraphEdges) import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..)) import Language.Haskell.TH.Desugar (withLocalDeclarations)@@ -162,8 +161,7 @@ " Language.Haskell.TH.Syntax.OccName -> fromList [(Language.Haskell.TH.Syntax.Name,Language.Haskell.TH.Syntax.Name,Left 1)]", " Language.Haskell.TH.Syntax.PkgName -> fromList [(Language.Haskell.TH.Syntax.NameFlavour,Language.Haskell.TH.Syntax.NameG,Left 2)]", " Language.Haskell.TH.Syntax.TyLit -> fromList [(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.LitT,Left 1)]",- " Language.Haskell.TH.Syntax.Type -> fromList [(Language.Haskell.TH.Syntax.TyVarBndr,Language.Haskell.TH.Syntax.KindedTV,Left 2),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.AppT,Left 1),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.AppT,Left 2),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.ForallT,Left 3),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.SigT,Left 1),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.SigT,Left 2)]",- " hints:" ]+ " Language.Haskell.TH.Syntax.Type -> fromList [(Language.Haskell.TH.Syntax.TyVarBndr,Language.Haskell.TH.Syntax.KindedTV,Left 2),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.AppT,Left 1),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.AppT,Left 2),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.ForallT,Left 3),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.SigT,Left 1),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.SigT,Left 2)]" ] #else [ "TypeGraphInfo:", " typeSet:",@@ -303,8 +301,7 @@ " Language.Haskell.TH.Syntax.OccName -> fromList [(Language.Haskell.TH.Syntax.Name,Language.Haskell.TH.Syntax.Name,Left 1)]", " Language.Haskell.TH.Syntax.PkgName -> fromList [(Language.Haskell.TH.Syntax.NameFlavour,Language.Haskell.TH.Syntax.NameG,Left 2)]", " Language.Haskell.TH.Syntax.TyLit -> fromList [(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.LitT,Left 1)]",- " Language.Haskell.TH.Syntax.Type -> fromList [(Language.Haskell.TH.Syntax.Pred,Language.Haskell.TH.Syntax.EqualP,Left 1),(Language.Haskell.TH.Syntax.Pred,Language.Haskell.TH.Syntax.EqualP,Left 2),(Language.Haskell.TH.Syntax.TyVarBndr,Language.Haskell.TH.Syntax.KindedTV,Left 2),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.AppT,Left 1),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.AppT,Left 2),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.ForallT,Left 3),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.SigT,Left 1),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.SigT,Left 2)]",- " hints:" ]+ " Language.Haskell.TH.Syntax.Type -> fromList [(Language.Haskell.TH.Syntax.Pred,Language.Haskell.TH.Syntax.EqualP,Left 1),(Language.Haskell.TH.Syntax.Pred,Language.Haskell.TH.Syntax.EqualP,Left 2),(Language.Haskell.TH.Syntax.TyVarBndr,Language.Haskell.TH.Syntax.KindedTV,Left 2),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.AppT,Left 1),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.AppT,Left 2),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.ForallT,Left 3),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.SigT,Left 1),(Language.Haskell.TH.Syntax.Type,Language.Haskell.TH.Syntax.SigT,Left 2)]" ] #endif subtypesOfType :: Set String
th-typegraph.cabal view
@@ -1,5 +1,5 @@ name: th-typegraph-version: 0.17.1+version: 0.18 cabal-version: >= 1.10 build-type: Simple license: BSD3@@ -34,7 +34,6 @@ 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 Language.Haskell.TH.TypeGraph.Monad Language.Haskell.TH.TypeGraph.Unsafe