comfort-graph 0.0.1 → 0.0.2

raw patch · 3 files changed

+103/−81 lines, 3 filesdep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: transformers

API changes (from Hackage documentation)

Files

• comfort-graph.cabal +5/−4
• src/Data/Graph/Comfort.hs +98/−47
• src/Data/Graph/Comfort/TypeConstructor.hs +0/−30

@@ -1,5 +1,5 @@ Name:                comfort-graph-Version:             0.0.1+Version:             0.0.2 Synopsis:            Graph structure with type parameters for nodes and edges Description:   This graph structure is based on "Data.Map"@@ -51,7 +51,7 @@ Cabal-Version:       >=1.10  Source-Repository this-  Tag:         0.0.1+  Tag:         0.0.2   Type:        darcs   Location:    http://hub.darcs.net/thielema/comfort-graph @@ -64,18 +64,19 @@     Data.Graph.Comfort   Other-Modules:     Data.Graph.Comfort.Map-    Data.Graph.Comfort.TypeConstructor     -- ToDo: should be replaced by future version of total-map     Data.Graph.Comfort.TotalMap   Build-Depends:     QuickCheck >=2.5 && <3,     containers >=0.4 && <0.6,-    transformers >=0.4 && <0.5,+    transformers >=0.5 && <0.6,     utility-ht >=0.0.10 && <0.1,     base >=4.5 && <5   Hs-Source-Dirs:      src   Default-Language:    Haskell2010   GHC-Options:         -Wall+  If impl(ghc>=8.0)+    GHC-Options: -fno-warn-redundant-constraints  Test-Suite test-comfort-graph   Type:                exitcode-stdio-1.0

@@ -50,9 +50,10 @@  import qualified Data.Graph.Comfort.Map as MapU import qualified Data.Graph.Comfort.TotalMap as TMap-import qualified Data.Graph.Comfort.TypeConstructor as TC -import Data.Functor.Classes (Eq1(eq1), Ord1(compare1), Show1(showsPrec1))+import Control.Monad.Trans.Identity (IdentityT(IdentityT, runIdentityT))+import Data.Functor.Classes+         (Eq1(liftEq), Ord1(liftCompare), Show1(liftShowsPrec))  import qualified Data.Set as Set import qualified Data.Map as Map@@ -63,20 +64,24 @@ import Data.Foldable (Foldable, foldMap) import Data.Set (Set) import Data.Map (Map)-import Data.Monoid (Monoid, mempty, mappend)+import Data.Monoid+         (Monoid, mempty, mappend, All(All), getAll, Endo(Endo), appEndo) import Data.Tuple.HT (mapFst, fst3, snd3, thd3, mapFst3, mapThd3)  import qualified Test.QuickCheck as QC  import Data.Functor (Functor, fmap) import Data.List (map, any, all, (++))+import Data.String (String) import Data.Maybe (Maybe)-import Data.Bool (Bool, not, (&&), (||))+import Data.Bool (Bool(False), not, (&&), (||)) import Data.Eq (Eq, (==))-import Data.Ord (Ord, compare, (<), (>))+import Data.Ord (Ord, Ordering(LT,GT), (<), (>)) import Data.Tuple (uncurry) import Data.Function (flip, (.), ($))-import Text.Show (Show, showParen, showString, showChar, shows, showsPrec)+import Data.Int (Int)+import Text.Show+         (Show, ShowS, showParen, showString, showChar, shows, showsPrec)  import Prelude (error) @@ -87,7 +92,7 @@ newtype Graph edge node edgeLabel nodeLabel =    Graph {       graphMapWrap ::-         Map node (InOutMap (TC.Wrap edge) node edgeLabel nodeLabel)+         Map node (InOutMap (Wrap edge) node edgeLabel nodeLabel)    } deriving (Eq, Ord)  instance@@ -183,19 +188,57 @@    deriving (Eq, Ord, Show)  -instance Eq1 DirEdge where eq1 = (==)-instance Ord1 DirEdge where compare1 = compare-instance Show1 DirEdge where showsPrec1 = showsPrec+liftBin ::+   (Edge edge, Monoid a) =>+   (node0 -> node1 -> a) -> edge node0 -> edge node1 -> a+liftBin op e0 e1 = mappend (op (from e0) (from e1)) (op (to e0) (to e1)) -instance Eq1 UndirEdge where eq1 = (==)-instance Ord1 UndirEdge where compare1 = compare-instance Show1 UndirEdge where showsPrec1 = showsPrec+liftEdgeEq ::+   Edge edge => (node0 -> node1 -> Bool) -> edge node0 -> edge node1 -> Bool+liftEdgeEq eq = (getAll .) . liftBin (\a b -> All $ eq a b) -instance Eq1 EitherEdge where eq1 = (==)-instance Ord1 EitherEdge where compare1 = compare-instance Show1 EitherEdge where showsPrec1 = showsPrec+liftEdgeShowsPrec ::+   (Foldable edge) =>+   String -> (Int -> node -> ShowS) -> showList -> Int -> edge node -> ShowS+liftEdgeShowsPrec name showsPrc _showsList p e =+   showParen (p>10) $+      showString name .+      appEndo (foldMap (\n -> Endo $ showChar ' ' . showsPrc 11 n) e) +instance Eq1 DirEdge where liftEq = liftEdgeEq+instance Ord1 DirEdge where liftCompare = liftBin+instance Show1 DirEdge where liftShowsPrec = liftEdgeShowsPrec "DirEdge" +instance Eq1 UndirEdge where liftEq = liftEdgeEq+instance Ord1 UndirEdge where liftCompare = liftBin+instance Show1 UndirEdge where liftShowsPrec = liftEdgeShowsPrec "UndirEdge"++instance Eq1 EitherEdge where+   liftEq eq ee0 ee1 =+      case (ee0, ee1) of+         (EDirEdge e0, EDirEdge e1) -> liftEq eq e0 e1+         (EUndirEdge e0, EUndirEdge e1) -> liftEq eq e0 e1+         _ -> False++instance Ord1 EitherEdge where+   liftCompare cmp ee0 ee1 =+      case (ee0, ee1) of+         (EDirEdge e0, EDirEdge e1) -> liftCompare cmp e0 e1+         (EUndirEdge e0, EUndirEdge e1) -> liftCompare cmp e0 e1+         (EDirEdge _, EUndirEdge _) -> LT+         (EUndirEdge _, EDirEdge _) -> GT++instance Show1 EitherEdge where+   liftShowsPrec showsPrc showsList p ee =+      case ee of+         EDirEdge e ->+            showParen (p>10) $+            showString "EDirEdge " . liftShowsPrec showsPrc showsList 11 e+         EUndirEdge e ->+            showParen (p>10) $+            showString "EUndirEdge " . liftShowsPrec showsPrc showsList 11 e++ instance Functor DirEdge where    fmap f (DirEdge x y) = DirEdge (f x) (f y) @@ -252,7 +295,7 @@ edgeLabelsWrap ::    (Edge edge, Ord node) =>    Graph edge node edgeLabel nodeLabel ->-   Map (TC.Wrap edge node) edgeLabel+   Map (Wrap edge node) edgeLabel edgeLabelsWrap = foldMap fst3 . graphMapWrap  edgeSet ::@@ -277,8 +320,8 @@           nl,           Map.mapKeys reverseEdgeWrap ins)) -reverseEdgeWrap :: Reverse edge => TC.Wrap edge node -> TC.Wrap edge node-reverseEdgeWrap = TC.Wrap . reverseEdge . TC.unwrap+reverseEdgeWrap :: Reverse edge => Wrap edge node -> Wrap edge node+reverseEdgeWrap = wrap . reverseEdge . unwrap   class Edge edge => Reverse edge where@@ -309,9 +352,9 @@    withWrappedGraph $    fmap       (\(ins,nl,outs) ->-         (Map.mapKeys (TC.Wrap . g . TC.unwrap) ins,+         (Map.mapKeys (wrap . g . unwrap) ins,           nl,-          Map.mapKeys (TC.Wrap . g . TC.unwrap) outs)) .+          Map.mapKeys (wrap . g . unwrap) outs)) .    Map.mapKeysWith (error "Graph.mapKeys: node map is not injective") f  empty :: Graph edge node edgeLabel nodeLabel@@ -362,14 +405,14 @@  lookupEdge :: (Edge e, Ord n) => e n -> Graph e n el nl -> Maybe el lookupEdge e (Graph g) =-   Map.lookup (TC.Wrap e) . thd3 =<< Map.lookup (from e) g+   Map.lookup (wrap e) . thd3 =<< Map.lookup (from e) g  {- | Alternative implementation for test: -} _lookupEdge :: (Edge e, Ord n) => e n -> Graph e n el nl -> Maybe el _lookupEdge e (Graph g) =-   Map.lookup (TC.Wrap e) . fst3 =<< Map.lookup (to e) g+   Map.lookup (wrap e) . fst3 =<< Map.lookup (to e) g   isEmpty :: Graph e n el nl -> Bool@@ -435,8 +478,8 @@    e n -> Graph e n el nl -> Graph e n el nl deleteEdge e =    withWrappedGraph $-      Map.adjust (mapThd3 $ Map.delete $ TC.Wrap e) (from e) .-      Map.adjust (mapFst3 $ Map.delete $ TC.Wrap e) (to e)+      Map.adjust (mapThd3 $ Map.delete $ wrap e) (from e) .+      Map.adjust (mapFst3 $ Map.delete $ wrap e) (to e)  filterEdgeWithKey ::    (Edge e, Ord n) =>@@ -446,8 +489,8 @@    Graph .    fmap       (\(ins, nl, outs) ->-         (Map.filterWithKey (f . TC.unwrap) ins, nl,-          Map.filterWithKey (f . TC.unwrap) outs)) .+         (Map.filterWithKey (f . unwrap) ins, nl,+          Map.filterWithKey (f . unwrap) outs)) .    graphMapWrap  {- |@@ -463,9 +506,9 @@    withWrappedGraph $    fmap       (\(ins, nl, outs) ->-         (MapU.mapMaybeKeys (fmap TC.Wrap . f . TC.unwrap) ins,+         (MapU.mapMaybeKeys (fmap wrap . f . unwrap) ins,           nl,-          MapU.mapMaybeKeys (fmap TC.Wrap . f . TC.unwrap) outs))+          MapU.mapMaybeKeys (fmap wrap . f . unwrap) outs))  {- | Same restrictions as in 'mapMaybeEdgeKeys'.@@ -478,9 +521,9 @@    withWrappedGraph $    fmap       (\(ins, nl, outs) ->-         (Map.mapKeys (TC.Wrap . f . TC.unwrap) ins,+         (Map.mapKeys (wrap . f . unwrap) ins,           nl,-          Map.mapKeys (TC.Wrap . f . TC.unwrap) outs))+          Map.mapKeys (wrap . f . unwrap) outs))  {- | In the current implementation@@ -527,7 +570,7 @@    (Edge e, Ord n) =>    [LabeledNode n nl] -> [LabeledEdge e n el] -> Graph e n el nl fromList ns es =-   fromMapWrap (Map.fromList ns) $ Map.fromList $ map (mapFst TC.Wrap) es+   fromMapWrap (Map.fromList ns) $ Map.fromList $ map (mapFst wrap) es  fromMap ::    (Edge e, Ord n) =>@@ -536,7 +579,7 @@  fromMapWrap ::    (Edge e, Ord n) =>-   Map n nl -> Map (TC.Wrap e n) el -> Graph e n el nl+   Map n nl -> Map (Wrap e n) el -> Graph e n el nl fromMapWrap ns es =    let ess = Map.mapWithKey Map.singleton es    in  Graph $@@ -563,7 +606,7 @@ mapEdgeWithKey :: (e n -> el0 -> el1) -> Graph e n el0 nl -> Graph e n el1 nl mapEdgeWithKey f =    Graph .-   fmap (\(ins,n,outs) -> (Map.mapWithKey (f . TC.unwrap) ins, n, Map.mapWithKey (f . TC.unwrap) outs)) .+   fmap (\(ins,n,outs) -> (Map.mapWithKey (f . unwrap) ins, n, Map.mapWithKey (f . unwrap) outs)) .    graphMapWrap  nodeSet :: Graph e n el nl -> Set n@@ -647,30 +690,38 @@  -- * Wrap utilities -unwrapMap :: Map (TC.Wrap e n) a -> Map (e n) a-unwrapMap = Map.mapKeysMonotonic TC.unwrap+type Wrap = IdentityT -wrapMap :: Map (e n) a -> Map (TC.Wrap e n) a-wrapMap = Map.mapKeysMonotonic TC.Wrap+wrap :: f a -> Wrap f a+wrap = IdentityT -unwrapSet :: Set (TC.Wrap f a) -> Set (f a)-unwrapSet = Set.mapMonotonic TC.unwrap+unwrap :: Wrap f a -> f a+unwrap = runIdentityT +unwrapMap :: Map (Wrap e n) a -> Map (e n) a+unwrapMap = Map.mapKeysMonotonic unwrap +wrapMap :: Map (e n) a -> Map (Wrap e n) a+wrapMap = Map.mapKeysMonotonic wrap++unwrapSet :: Set (Wrap f a) -> Set (f a)+unwrapSet = Set.mapMonotonic unwrap++ type InOutMap e n el nl = (Map (e n) el, nl, Map (e n) el) -unwrapInOut :: InOutMap (TC.Wrap e) n el nl -> InOutMap e n el nl+unwrapInOut :: InOutMap (Wrap e) n el nl -> InOutMap e n el nl unwrapInOut = mapFst3 unwrapMap . mapThd3 unwrapMap  withWrappedGraph ::-   (Map n0 (InOutMap (TC.Wrap e0) n0 el0 nl0) ->-    Map n1 (InOutMap (TC.Wrap e1) n1 el1 nl1)) ->+   (Map n0 (InOutMap (Wrap e0) n0 el0 nl0) ->+    Map n1 (InOutMap (Wrap e1) n1 el1 nl1)) ->    Graph e0 n0 el0 nl0 -> Graph e1 n1 el1 nl1 withWrappedGraph f =    Graph . f . graphMapWrap -fromWrap :: (Edge edge) => TC.Wrap edge node -> node-fromWrap = from . TC.unwrap+fromWrap :: (Edge edge) => Wrap edge node -> node+fromWrap = from . unwrap -toWrap :: (Edge edge) => TC.Wrap edge node -> node-toWrap   = to   . TC.unwrap+toWrap :: (Edge edge) => Wrap edge node -> node+toWrap   = to   . unwrap

@@ -1,30 +0,0 @@--- similar to prelude-extras-module Data.Graph.Comfort.TypeConstructor (-   Wrap(Wrap, unwrap),-   ) where--import Data.Functor.Classes (Eq1(eq1), Ord1(compare1), Show1(showsPrec1))--import Data.Traversable (Traversable, traverse)-import Data.Foldable (Foldable, foldMap)---newtype Wrap f a = Wrap {unwrap :: f a}--instance (Eq1 f, Eq a) => Eq (Wrap f a) where-   Wrap x == Wrap y  =  eq1 x y--instance (Ord1 f, Ord a) => Ord (Wrap f a) where-   compare (Wrap x) (Wrap y)  =  compare1 x y--instance (Show1 f, Show a) => Show (Wrap f a) where-   showsPrec p (Wrap x)  =  showsPrec1 p x--instance Functor f => Functor (Wrap f) where-   fmap f (Wrap a) = Wrap (fmap f a)--instance Foldable f => Foldable (Wrap f) where-   foldMap f (Wrap a) = foldMap f a--instance Traversable f => Traversable (Wrap f) where-   traverse f (Wrap a) = fmap Wrap $ traverse f a