dag 0.0.2.1 → 0.1

raw patch · 4 files changed

+162/−78 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• dag.cabal +38/−6
• src/Data/Graph/DAG.hs +22/−32
• src/Data/Graph/DAG/Edge.hs +5/−4
• src/Data/Graph/DAG/Edge/Utils.hs +97/−36

@@ -1,10 +1,10 @@ Name:                   dag-Version:                0.0.2.1+Version:                0.1 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3 License-File:           LICENSE-Synopsis:               Basic type-safe directed acyclic graphs.+Synopsis:               Compile-time, type-safe directed acyclic graphs. Description:   This is a type-safe approach for a directed acyclic graph.   .@@ -46,10 +46,10 @@   >   >  getSpanningTrees $ edges   >    :: Data.Proxy.Proxy-  >         '['Node "foo" '['Node "bar" '['Node "baz" '[]],-  >                         'Node "baz" '[]],-  >           'Node "bar" '['Node "baz" '[]],-  >           'Node "baz" '[]]+  >         '['Node "foo" '['Node "bar" '['Node "baz" '[]]+  >                        ,'Node "baz" '[]]+  >          ,'Node "bar" '['Node "baz" '[]]+  >          ,'Node "baz" '[]]   >   >  *Data.Graph.DAG> reflect $ getSpanningTrees $ edges   >@@ -58,8 +58,40 @@   >    ,Node "bar" [Node "baz" []]   >    ,Node "baz" []]   .+  We can also look at the edges, first-class:+  .+  >  *Data.Graph.DAG> fcEdges edges+  >+  >    [("foo","bar"),("foo","baz"),("bar","baz")]+  .+  Node construction is done with a uniquely keyed (inductive) map:+  .+  >  data Cool = AllRight | Radical | SuperDuper deriving (Show, Eq)+  >  nodes =+  >    nadd "foo" AllRight $+  >    nadd "bar" Radical $+  >    nadd "baz" SuperDuper $+  >    nempty+  .+  Note that a @NodeSchema@'s keys don't have to be in-sync with it's paired+  @EdgeSchema@. After we have both, we can construct a @DAG@:+  .+  >  graph = DAG edges nodes+  .+  Now we can do fun things, like get the spanning tree of a node:+  .+  >  *Data.Graph.DAG> gtree "foo" graph+  >+  >    Just (AllRight :@-> [Radical :@-> [SuperDuper :@-> []]+  >                        ,SuperDuper :@-> []])+  .   This library is still very naive, but it will give us compile-time enforcement   of acyclicity (and uniqueness) in these graphs - ideal for dependency graphs.+  .+  The main deficiency of this graph is that our @EdgeSchema@ can't be+  /deconstructed/ soundly - there is just too much information loss between the+  value and type levels. This means we can't delete edges or look inside, but we+  can still add edges or work with the resulting structure.  Cabal-Version:          >= 1.10 Build-Type:             Simple

@@ -7,50 +7,40 @@ module Data.Graph.DAG         ( module Data.Graph.DAG.Edge         , module Data.Graph.DAG.Edge.Utils+        , module Data.Graph.DAG.Node         , DAG (..)         , glookup         ) where  import Data.Graph.DAG.Edge import Data.Graph.DAG.Edge.Utils+import Data.Graph.DAG.Node  import Data.List (lookup) import Data.Singletons import Data.Proxy---- | The graph may be not connected-data DAG es a = forall x unique. GNil (EdgeSchema es x unique)-              | GCons String a (DAG es a)--instance Functor (DAG es) where-  fmap f (GNil e) = GNil e-  fmap f (GCons k x xs) = GCons k (f x) $-    fmap f xs--{---- | Convenience function.--- getEdgeSchema :: DAG es-getEdgeSchema (GNil e) = e-getEdgeSchema (GCons _ _ gs) = getEdgeSchema gs--}+import Data.Maybe (fromJust) --- | A simple @Data.Map.lookup@ duplicate.-glookup :: String -> DAG es a -> Maybe a-glookup _ (GNil _) = Nothing-glookup k (GCons k2 a gs) | k == k2   = Just a-                          | otherwise = glookup k gs+-- | A (potentially sparse) directed acyclic graph, composed of edges and nodes.+data DAG es x u a = DAG { getEdgeSchema :: (EdgeSchema es x u)+                        , getNodeSchema :: (NodeSchema a)+                        } --- | Get the spanning trees of an @EdgeSchema@. Operate on the assumtion that--- the data returned is actually @[Tree String]@.-espanningtrees :: SingI (SpanningTrees' es '[]) =>-                  EdgeSchema es x unique-               -> Demote (SpanningTrees' es '[])-espanningtrees = reflect . getSpanningTrees+instance Functor (DAG es x u) where+  fmap f (DAG es xs) = DAG es $ fmap f xs --- gspanningtrees+-- | @Data.Map.lookup@ duplicate.+glookup :: String -> DAG es x u a -> Maybe a+glookup k (DAG _ xs) = nlookup k xs +-- | Spanning trees of a graph.+gspanningtrees :: SingI (SpanningTrees' es '[]) =>+                  DAG es x u a -> [RTree a]+gspanningtrees g = fmap replace $ espanningtrees $ getEdgeSchema g+  where+  replace = fmap $ fromJust . flip glookup g -{--gtree :: String -> DAG es a -> Maybe (Tree a)-gtree k g = lookup k $ force $ reflect $ getSpanningTrees $ getEdgeSchema g--}+-- | Spanning tree of a particular node. "A possible tree of possible results"+gtree :: SingI (SpanningTrees' es '[]) =>+         String -> DAG es x unique a -> Maybe (RTree a)+gtree k g = fmap (fmap $ fromJust . flip glookup g) $ etree k $ getEdgeSchema g

@@ -76,15 +76,15 @@ type family DisallowIn               (new :: EdgeKind)               ( oldLoops :: [(Symbol, [Symbol])] )-              (keyFound :: Bool) :: [(Symbol, [Symbol])] where+              (keyFoundYet :: Bool) :: [(Symbol, [Symbol])] where -- When @from ~ key@:   DisallowIn ('EdgeType from to) ( '(from, xs) ': es) 'False =     '(from, (to ': xs)) ':                      -- add @to@ to transitive reach list       (DisallowIn ('EdgeType from to) es 'True) -- continue -- When @from ~/~ key@, and @from ~/~ head value@-  DisallowIn ('EdgeType from to) ( '(key, vs) ': es ) keyFound =+  DisallowIn ('EdgeType from to) ( '(key, vs) ': es ) keyFoundYet =     '(key, (PrependIfElem from to vs)) ':            -- find the needle if it exists-        (DisallowIn ('EdgeType from to) es keyFound) -- continue+        (DisallowIn ('EdgeType from to) es keyFoundYet) -- continue -- Basis   DisallowIn a '[] 'True = '[] -- search over. -- Growth via append@@ -104,7 +104,8 @@              -> !(EdgeSchema old oldLoops unique)              -> EdgeSchema (b ': old) c unique --- | Utility for constructing an @EdgeSchema@ granularly+-- | Utility for constructing an @EdgeSchema@ incrementally without a type+-- signature. unique :: EdgeSchema '[] '[] 'True unique = ENil 

@@ -20,31 +20,35 @@ import Data.Singletons.Prelude import Data.Proxy import Data.Monoid+import Data.Foldable (Foldable (foldMap)) import Control.Applicative  -- | Trivial rose tree for creating spanning trees. We make control structure -- instances "parallel" (instead of cartesian) by default for simplicity. $(singletons [d|-  data Tree a = Node a [Tree a] deriving (Show, Eq, Functor)+  data RTree a = a :@-> [RTree a] deriving (Show, Eq, Functor)   |]) -instance Applicative Tree where-  pure a = Node a []-  (Node f fs) <*> (Node x xs) = Node (f x) $-    zipWith (<*>) fs xs+instance Applicative RTree where+  pure a = a :@-> []+  (f :@-> fs) <*> (x :@-> xs) = (f x) :@->+    (zipWith (<*>) fs xs) -instance Monad Tree where+instance Monad RTree where   return = pure-  (Node x xs) >>= f = case f x of -- Substitution based instance.-    (Node y ys) -> Node y $ fmap (>>= f) xs+  (x :@-> xs) >>= f = case f x of -- Substitution based instance.+    (y :@-> ys) -> y :@-> (fmap (>>= f) xs) -instance Monoid a => Monoid (Tree a) where-  mempty = Node mempty []-  (Node x xs) `mappend` (Node y ys) = Node (x `mappend` y) $-    zipWith mappend xs ys+instance Monoid a => Monoid (RTree a) where+  mempty = mempty :@-> []+  (x :@-> xs) `mappend` (y :@-> ys) = (x `mappend` y) :@->+    (zipWith mappend xs ys) +instance Foldable RTree where+  foldMap f (x :@-> xs) = f x <> foldMap (foldMap f) xs+ -- | Gives us a generic way to get our spanning trees of the graph, as a value.--- Credit goes to <stackoverflow.com/questions/28030118/reflecting-heterogeneous-promoted-types-back-to-values-compositionally András Kovács>.+-- Credit goes to <http://stackoverflow.com/questions/28030118/reflecting-heterogeneous-promoted-types-back-to-values-compositionally András Kovács>. reflect ::   forall (a :: k).   (SingI a, SingKind ('KProxy :: KProxy k)) =>@@ -52,66 +56,123 @@ reflect _ = fromSing (sing :: Sing a)  -- | Adds an empty @c@ tree to the list of trees uniquely-type family AppendIfNotElemTrees (c :: k) (trees :: [Tree k]) :: [Tree k] where-  AppendIfNotElemTrees c ((Node c xs) ': xss) = (Node c xs) ': xss-  AppendIfNotElemTrees c ((Node x xs) ': xss) = (Node x xs) ':+type family AppendIfNotElemTrees (c :: k) (trees :: [RTree k]) :: [RTree k] where+  AppendIfNotElemTrees c ((c :@-> xs) ': xss) = (c :@-> xs) ': xss+  AppendIfNotElemTrees c ((x :@-> xs) ': xss) = (x :@-> xs) ':     (AppendIfNotElemTrees c xss)-  AppendIfNotElemTrees c '[] = (Node c '[]) ': '[]+  AppendIfNotElemTrees c '[] = (c :@-> '[]) ': '[]  -- | Adds @c@ as a child of any tree with a root @t@. Assumes unique roots. type family AddChildTo (test :: k)                        (child :: k)-                       (trees :: [Tree k]) :: [Tree k] where-  AddChildTo t c ((Node t xs) ': xss) =-    (Node t (AppendIfNotElemTrees c xs)) ': (AddChildTo t c xss)-  AddChildTo t c ((Node x xs) ': xss) =-    (Node x (AddChildTo t c xs)) ': (AddChildTo t c xss)+                       (trees :: [RTree k]) :: [RTree k] where+  AddChildTo t c ((t :@-> xs) ': xss) =+    (t :@-> (AppendIfNotElemTrees c xs)) ': (AddChildTo t c xss)+  AddChildTo t c ((x :@-> xs) ': xss) =+    (x :@-> (AddChildTo t c xs)) ': (AddChildTo t c xss)   AddChildTo t c '[] = '[]  -- | We need to track if @from@ has is a root node or not. TODO: Some code repeat. type family AddEdge' (edge :: EdgeKind)-                     (trees :: [Tree Symbol])+                     (trees :: [RTree Symbol])                      (hasFromRoot :: Bool)-                     (hasToRoot :: Bool):: [Tree Symbol] where+                     (hasToRoot :: Bool):: [RTree Symbol] where   AddEdge' ('EdgeType from to) '[] 'False 'False =-    (Node from ((Node to '[]) ': '[])) ': (Node to '[]) ': '[]+    (from :@-> ((to :@-> '[]) ': '[])) ': (to :@-> '[]) ': '[]    AddEdge' ('EdgeType from to) '[] 'True 'False =-    (Node to                     '[])  ':                  '[]+    (to :@->                     '[])  ':                  '[]    AddEdge' ('EdgeType from to) '[] 'False 'True =-    (Node from ((Node to '[]) ': '[])) ':                  '[]+    (from :@-> ((to :@-> '[]) ': '[])) ':                  '[]    AddEdge' x '[] 'True 'True = '[] -  AddEdge' ('EdgeType from to) ((Node from xs) ': xss) hasFromRoot hasToRoot =-    (Node from (AppendIfNotElemTrees to xs)) ':+  AddEdge' ('EdgeType from to) ((from :@-> xs) ': xss) hasFromRoot hasToRoot =+    (from :@-> (AppendIfNotElemTrees to xs)) ':       (AddEdge' ('EdgeType from to) xss 'True hasToRoot) -  AddEdge' ('EdgeType from to) ((Node to xs) ': xss) hasFromRoot hasToRoot =-    (Node to (AddEdge' ('EdgeType from to) xs 'True 'True)) ':+  AddEdge' ('EdgeType from to) ((to :@-> xs) ': xss) hasFromRoot hasToRoot =+    (to :@-> (AddEdge' ('EdgeType from to) xs 'True 'True)) ':       (AddEdge' ('EdgeType from to) xss hasFromRoot 'True)    -- Go downward, and laterally (I think).-  AddEdge' ('EdgeType from to) ((Node x xs) ': xss) hasFromRoot hasToRoot =-    (Node x (AddEdge' ('EdgeType from to) xs 'True 'True)) ':+  AddEdge' ('EdgeType from to) ((x :@-> xs) ': xss) hasFromRoot hasToRoot =+    (x :@-> (AddEdge' ('EdgeType from to) xs 'True 'True)) ':       (AddEdge' ('EdgeType from to) xss hasFromRoot hasToRoot)  -- | Add @to@ as a child to every @from@ node in the accumulator. type family AddEdge (edge :: EdgeKind)-                    (trees :: [Tree Symbol]) :: [Tree Symbol] where+                    (trees :: [RTree Symbol]) :: [RTree Symbol] where   AddEdge a trees = AddEdge' a trees 'False 'False  -- | Auxilliary function normally defined in a @where@ clause for manual folding. type family SpanningTrees' (edges :: [EdgeKind])-                           (acc :: [Tree Symbol]) :: [Tree Symbol] where+                           (acc :: [RTree Symbol]) :: [RTree Symbol] where   SpanningTrees' '[] trees = trees   SpanningTrees' (('EdgeType from to) ': es) trees =     SpanningTrees' es (AddEdge ('EdgeType from to) trees)  -- | Expects edges to already be type-safe-type family SpanningTrees (edges :: [EdgeKind]) :: [Tree Symbol] where+type family SpanningTrees (edges :: [EdgeKind]) :: [RTree Symbol] where   SpanningTrees edges = SpanningTrees' edges '[]  getSpanningTrees :: EdgeSchema es x unique -> Proxy (SpanningTrees es) getSpanningTrees _ = Proxy++-- | Get the spanning trees of an @EdgeSchema@. Operate on the assumtion that+-- the data returned is actually @[Tree String]@.+espanningtrees :: SingI (SpanningTrees' es '[]) =>+                  EdgeSchema es x unique+               -> Demote (SpanningTrees' es '[])+espanningtrees = reflect . getSpanningTrees++-- | Get a single tree.+etree :: SingI (SpanningTrees' es '[]) =>+         String -> EdgeSchema es x unique -> Maybe (RTree String)+etree k es = getTree k $ espanningtrees es+  where+  getTree k1 ( n@(k2 :@-> xs) : ns ) | k1 == k2 = Just n+                                     | otherwise = getTree k1 ns+  getTree _ [] = Nothing++-- | Degenerate (but type-safe!) @head@.+ehead :: ( EdgeType from to ~ b+         , EdgeValue from to ~ a+         ) => EdgeSchema (b ': old) c u -> a+ehead _ = Edge++-- | For now, we only suport unique edges.+eTreeToEdges :: RTree String -> [(String,String)]+eTreeToEdges = treeToEdges' []+  where+  treeToEdges' :: [(String,String)]+               -> RTree String+               -> [(String,String)]+  treeToEdges' zs (_ :@-> []) = zs+  treeToEdges' zs (x :@-> xs) =+    let newEdges = umerge zs $ map (\q -> (x, getNodeVal q)) xs+    in+    foldl treeToEdges' newEdges xs+  getNodeVal (x :@-> _) = x+  -- unique merge+  umerge [] ys = ys+  umerge (x:xs) ys | x `elem` ys = umerge xs ys+                   | otherwise = x : umerge xs ys++-- | Get a first-class list of edges from spanning trees. Only works on uniqely+-- edged @EdgeSchema@'s.+eForestToEdges :: [RTree String] -> [(String,String)]+eForestToEdges xs = foldl (\es t -> umerge es $ eTreeToEdges t) [] xs+  where+  -- unique merge+  umerge [] ys = ys+  umerge (x:xs) ys | x `elem` ys = umerge xs ys+                   | otherwise = x : umerge xs ys++-- | Get the "First-Class" edges of a uniquely-edged @EdgeSchema@.+fcEdges :: SingI (SpanningTrees' es '[]) =>+           EdgeSchema es x 'True -> [(String, String)]+fcEdges = eForestToEdges . espanningtrees++-- eflip e = espanningtrees e