diff --git a/Language/Haskell/TH/TypeGraph.hs b/Language/Haskell/TH/TypeGraph.hs --- a/Language/Haskell/TH/TypeGraph.hs +++ b/Language/Haskell/TH/TypeGraph.hs @@ -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 () diff --git a/Language/Haskell/TH/TypeGraph/Graph.hs b/Language/Haskell/TH/TypeGraph/Graph.hs --- a/Language/Haskell/TH/TypeGraph/Graph.hs +++ b/Language/Haskell/TH/TypeGraph/Graph.hs @@ -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 diff --git a/Language/Haskell/TH/TypeGraph/Hints.hs b/Language/Haskell/TH/TypeGraph/Hints.hs deleted file mode 100644 --- a/Language/Haskell/TH/TypeGraph/Hints.hs +++ /dev/null @@ -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] diff --git a/Language/Haskell/TH/TypeGraph/Info.hs b/Language/Haskell/TH/TypeGraph/Info.hs --- a/Language/Haskell/TH/TypeGraph/Info.hs +++ b/Language/Haskell/TH/TypeGraph/Info.hs @@ -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 diff --git a/Language/Haskell/TH/TypeGraph/Monad.hs b/Language/Haskell/TH/TypeGraph/Monad.hs --- a/Language/Haskell/TH/TypeGraph/Monad.hs +++ b/Language/Haskell/TH/TypeGraph/Monad.hs @@ -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 diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -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 diff --git a/test/TypeGraph.hs b/test/TypeGraph.hs --- a/test/TypeGraph.hs +++ b/test/TypeGraph.hs @@ -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 diff --git a/test/Values.hs b/test/Values.hs --- a/test/Values.hs +++ b/test/Values.hs @@ -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 diff --git a/th-typegraph.cabal b/th-typegraph.cabal --- a/th-typegraph.cabal +++ b/th-typegraph.cabal @@ -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