packages feed

th-typegraph 0.17 → 0.17.1

raw patch · 5 files changed

+47/−71 lines, 5 files

Files

Language/Haskell/TH/TypeGraph.hs view
@@ -12,7 +12,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, Hidden, Sink, Divert, Extra))+import Language.Haskell.TH.TypeGraph.Hints (VertexHint(Normal, 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)
Language/Haskell/TH/TypeGraph/Core.hs view
@@ -18,8 +18,10 @@     , typeArity     -- * Pretty print without extra whitespace     , pprint'+    , unlifted     ) where +import Control.Applicative ((<$>), (<*>)) import Data.Generics (Data, everywhere, mkT) import Data.Map as Map (Map, fromList, toList) import Data.Set as Set (Set, fromList, toList)@@ -143,3 +145,32 @@  instance Lift (E Type) where     lift etype = [|markExpanded $(lift (runExpanded etype))|]++-- | Does the type or the declaration to which it refers contain a+-- primitive (aka unlifted) type?  This will traverse down any 'Dec'+-- to the named types, and then check whether any of their 'Info'+-- records are 'PrimTyConI' values.+class IsUnlifted t where+    unlifted :: Quasi m => t -> m Bool++instance IsUnlifted Dec where+    unlifted (DataD _ _ _ cons _) = or <$> mapM unlifted cons+    unlifted (NewtypeD _ _ _ con _) = unlifted con+    unlifted (TySynD _ _ typ) = unlifted typ+    unlifted _ = return False++instance IsUnlifted Con where+    unlifted (ForallC _ _ con) = unlifted con+    unlifted (NormalC _ ts) = or <$> mapM (unlifted . snd) ts+    unlifted (RecC _ ts) = or <$> mapM (\ (_, _, t) -> unlifted t) ts+    unlifted (InfixC t1 _ t2) = or <$> mapM (unlifted . snd) [t1, t2]++instance IsUnlifted Type where+    unlifted (ForallT _ _ typ) = unlifted typ+    unlifted (ConT name) = qReify name >>= unlifted+    unlifted (AppT t1 t2) = (||) <$> unlifted t1 <*> unlifted t2+    unlifted _ = return False++instance IsUnlifted Info where+    unlifted (PrimTyConI _ _ _) = return True+    unlifted _ = return False -- traversal stops here
Language/Haskell/TH/TypeGraph/Hints.hs view
@@ -27,8 +27,6 @@ -- 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     deriving (Eq, Ord, Show)@@ -38,15 +36,11 @@  instance Lift VertexHint where     lift Normal = [|Normal|]-    lift Hidden = [|Hidden|]-    lift Sink = [|Sink|]     lift (Divert x) = [|Divert $(lift x)|]     lift (Extra x) = [|Extra $(lift x)|]  instance Ppr VertexHint where     ppr Normal = ptext "Normal"-    ppr Hidden = ptext "Hidden"-    ppr Sink = ptext "Sink"     ppr (Divert x) = hcat [ptext "Divert (", ppr x, ptext ")"]     ppr (Extra x) = hcat [ptext "Extra (", ppr x, ptext ")"]
Language/Haskell/TH/TypeGraph/Monad.hs view
@@ -30,30 +30,22 @@ import Control.Monad.Reader (MonadReader) import Control.Monad.State (execStateT, modify, StateT) import Data.Default (Default(def))+import Data.Foldable import Data.List as List (map)-import Data.Map as Map ((!), findWithDefault, map, mapKeys, mapWithKey, alter)-import Data.Set as Set (delete, empty, insert, map, Set, singleton)+import Data.Map as Map ((!), alter, findWithDefault, map, mapKeysWith, mapWithKey)+import Data.Monoid (Monoid, (<>))+import Data.Set as Set (delete, empty, insert, map, Set, singleton, union) import Language.Haskell.Exts.Syntax () import Language.Haskell.TH -- (Con, Dec, nameBase, Type) import Language.Haskell.TH.TypeGraph.Core (Field) import Language.Haskell.TH.TypeGraph.Expand (E(E), expandType)-import Language.Haskell.TH.TypeGraph.Graph (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.TypeGraph.Graph (GraphEdges)+import Language.Haskell.TH.TypeGraph.Info (TypeGraphInfo, fields, infoMap, synonyms, typeSet)+import Language.Haskell.TH.TypeGraph.Vertex (TypeGraphVertex(..), etype, field) import Language.Haskell.TH.Desugar as DS (DsMonad) import Language.Haskell.TH.Instances () import Prelude hiding (foldr, mapM_, null) -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@@ -83,56 +75,13 @@ 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, 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 {->>= t1-} >>= execStateT (view hints >>= mapM doHint) {->>= t2-}-    where-      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))--      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 hint m. (DsMonad m, Functor m, Default hint, MonadReader (TypeGraphInfo hint) m) =>-             m (GraphEdges hint TypeGraphVertex)-findEdges = do+typeGraphEdges :: forall hint m. (DsMonad m, Functor m, Default hint, MonadReader (TypeGraphInfo hint) m) =>+                  m (GraphEdges hint TypeGraphVertex)+typeGraphEdges = do   execStateT (view typeSet >>= \ts -> mapM_ (\t -> expandType t >>= doType) ts) mempty     where       doType :: E Type -> StateT (GraphEdges hint TypeGraphVertex) m ()@@ -190,10 +139,12 @@ -- | 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 :: GraphEdges hint TypeGraphVertex -> GraphEdges hint TypeGraphVertex+simpleEdges :: Monoid hint => GraphEdges hint TypeGraphVertex -> GraphEdges hint TypeGraphVertex simpleEdges = Map.mapWithKey (\v (n, s) -> (n, Set.delete v s)) .    -- delete any self edges-              Map.mapKeys simpleVertex .               -- simplify each vertex+              Map.mapKeysWith combine simpleVertex .   -- simplify each vertex               Map.map (over _2 (Set.map simpleVertex)) -- simplify the out edges+    where+      combine (n1, s1) (n2, s2) = (n1 <> n2, Set.union s1 s2)  simpleVertex :: TypeGraphVertex -> TypeGraphVertex simpleVertex v = v {_field = Nothing}
th-typegraph.cabal view
@@ -1,5 +1,5 @@ name:               th-typegraph-version:            0.17+version:            0.17.1 cabal-version:      >= 1.10 build-type:         Simple license:            BSD3