├── test ├── Spec.hs └── Data │ └── Graph │ └── DAGSpec.hs ├── .gitignore ├── LICENSE ├── src └── Data │ └── Graph │ ├── DAG.hs │ └── DAG │ ├── Node.hs │ ├── Edge.hs │ └── Edge │ └── Utils.hs ├── README.md └── dag.cabal /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virthualenv 8 | .hsenv 9 | .cabal-sandbox/ 10 | cabal.sandbox.config 11 | -------------------------------------------------------------------------------- /test/Data/Graph/DAGSpec.hs: -------------------------------------------------------------------------------- 1 | module Data.Graph.DAGSpec (main, spec) where 2 | 3 | import Data.Graph.DAG 4 | 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | import Test.QuickCheck.Instances 8 | 9 | main :: IO () 10 | main = hspec spec 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "someFunction" $ do 15 | it "should work fine" $ do 16 | property someFunction 17 | 18 | someFunction :: Bool -> Bool -> Property 19 | someFunction x y = x === y 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Athan Clark 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Athan Clark nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Data/Graph/DAG.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE ExistentialQuantification #-} 6 | 7 | module Data.Graph.DAG 8 | ( module Data.Graph.DAG.Edge 9 | , module Data.Graph.DAG.Edge.Utils 10 | , module Data.Graph.DAG.Node 11 | , DAG (..) 12 | , glookup 13 | ) where 14 | 15 | import Data.Graph.DAG.Edge 16 | import Data.Graph.DAG.Edge.Utils 17 | import Data.Graph.DAG.Node 18 | 19 | import Data.List (lookup) 20 | import Data.Singletons 21 | import Data.Proxy 22 | import Data.Maybe (fromJust) 23 | 24 | -- | A (potentially sparse) directed acyclic graph, composed of edges and nodes. 25 | data DAG es x u a = DAG { getEdgeSchema :: (EdgeSchema es x u) 26 | , getNodeSchema :: (NodeSchema a) 27 | } 28 | 29 | instance Functor (DAG es x u) where 30 | fmap f (DAG es xs) = DAG es $ fmap f xs 31 | 32 | -- | @Data.Map.lookup@ duplicate. 33 | glookup :: String -> DAG es x u a -> Maybe a 34 | glookup k (DAG _ xs) = nlookup k xs 35 | 36 | -- | Spanning trees of a graph. 37 | gspanningtrees :: SingI (SpanningTrees' es '[]) => 38 | DAG es x u a -> [RTree a] 39 | gspanningtrees g = fmap replace $ espanningtrees $ getEdgeSchema g 40 | where 41 | replace = fmap $ fromJust . flip glookup g 42 | 43 | -- | Spanning tree of a particular node. "A possible tree of possible results" 44 | gtree :: SingI (SpanningTrees' es '[]) => 45 | String -> DAG es x unique a -> Maybe (RTree a) 46 | gtree k g = fmap (fmap $ fromJust . flip glookup g) $ etree k $ getEdgeSchema g 47 | -------------------------------------------------------------------------------- /src/Data/Graph/DAG/Node.hs: -------------------------------------------------------------------------------- 1 | module Data.Graph.DAG.Node 2 | ( NodeSchema 3 | , nlookup 4 | , nremove 5 | , ncombine 6 | , nadd 7 | , nempty 8 | ) where 9 | 10 | import Data.Monoid 11 | 12 | -- | This is just a simple inductive list 13 | data NodeSchema a = GNil 14 | | GCons String a (NodeSchema a) 15 | deriving (Show, Eq) 16 | 17 | instance Functor NodeSchema where 18 | fmap f GNil = GNil 19 | fmap f (GCons k x xs) = GCons k (f x) $ fmap f xs 20 | 21 | -- | Simple lookup function. 22 | nlookup :: String -> NodeSchema a -> Maybe a 23 | nlookup _ GNil = Nothing 24 | nlookup k1 (GCons k2 x xs) | k1 == k2 = Just x 25 | | otherwise = nlookup k1 xs 26 | 27 | -- | We overwrite with rightward prescedence. 28 | ncombine :: NodeSchema a -> NodeSchema a -> NodeSchema a 29 | ncombine GNil ys = ys 30 | ncombine (GCons k1 x xs) 31 | (GCons k2 y ys) | k1 == k2 = 32 | GCons k1 y $ ncombine xs ys 33 | | otherwise = 34 | GCons k1 x $ GCons k2 y $ ncombine xs ys 35 | 36 | -- | Delete a node from a collection of nodes. 37 | nremove :: String -> NodeSchema a -> NodeSchema a 38 | nremove _ GNil = GNil 39 | nremove k1 (GCons k2 x xs) | k1 == k2 = xs 40 | | otherwise = nremove k1 xs 41 | 42 | -- | Uniquely append, or overwrite a node to a collection of nodes. 43 | nadd :: String -> a -> NodeSchema a -> NodeSchema a 44 | nadd k a GNil = GCons k a GNil 45 | nadd k1 a (GCons k2 x xs) | k1 == k2 = GCons k1 a xs 46 | | otherwise = GCons k2 x $ nadd k1 a xs 47 | 48 | -- | Smart constructor for @GNil@. 49 | nempty :: NodeSchema a 50 | nempty = GNil 51 | 52 | instance Monoid (NodeSchema a) where 53 | mempty = GNil 54 | mappend = ncombine 55 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Stories in Ready](https://badge.waffle.io/athanclark/dag.png?label=ready&title=Ready)](https://waffle.io/athanclark/dag) 2 | dag 3 | === 4 | 5 | > Directed Acyclic Graphs for Haskell 6 | 7 | ## Description 8 | 9 | This is a type-safe directed acyclic graph library for Haskell. This library 10 | differs from others in a number of ways: 11 | 12 | - Edge construction is incremental, creating a "schema": 13 | 14 | ```haskell 15 | {-# LANGUAGE DataKinds #-} 16 | 17 | import Data.Graph.DAG.Edge 18 | 19 | -- | Edges are statically defined: 20 | edges = ECons (Edge :: EdgeValue "foo" "bar") $ 21 | ECons (Edge :: EdgeValue "bar" "baz") $ 22 | ECons (Edge :: EdgeValue "foo" "baz") 23 | unique -- ENil, but casted for uniquely edged graphs 24 | ``` 25 | 26 | - The nodes are separate from edges; graph may be not connected: 27 | 28 | ```haskell 29 | data Cool = AllRight 30 | | Radical 31 | | SuperDuper 32 | 33 | graph = GCons "foo" AllRight $ 34 | GCons "bar" Radical $ 35 | GCons "baz" SuperDuper $ 36 | GNil edges 37 | ``` 38 | 39 | - Type safety throughout edge construction: 40 | 41 | ```haskell 42 | *Data.Graph.DAG> :t edges 43 | edges 44 | :: EdgeSchema 45 | '['EdgeType "foo" "bar", 'EdgeType "bar" "baz", 46 | 'EdgeType "foo" "baz"] -- Type list of edges 47 | '['("foo", '["bar", "baz"]), '("bar", '["baz"])] -- potential loops 48 | 'True -- uniqueness 49 | ``` 50 | 51 | - Various type-level computation 52 | 53 | ```haskell 54 | *Data.Graph.DAG> :t getSpanningTrees $ edges 55 | getSpanningTrees $ edges 56 | :: Data.Proxy.Proxy 57 | '['Node "foo" '['Node "bar" '['Node "baz" '[]], 58 | 'Node "baz" '[]], 59 | 'Node "bar" '['Node "baz" '[]], 60 | 'Node "baz" '[]] 61 | 62 | *Data.Graph.DAG> reflect $ getSpanningTrees $ edges 63 | [Node "foo" [Node "bar" [Node "baz" []] 64 | ,Node "baz" []] 65 | ,Node "bar" [Node "baz" []] 66 | ,Node "baz" []] 67 | ``` 68 | 69 | This library is still very naive, but it will give us compile-time enforcement 70 | of acyclicity in these graphs - ideal for dependency graphs. 71 | 72 | ## Usage 73 | 74 | You will need `-XDataKinds` for the type-level symbols: 75 | 76 | ```haskell 77 | {-# LANGUAGE DataKinds #-} 78 | 79 | import Data.Graph.DAG 80 | import GHC.TypeLits 81 | 82 | ... 83 | ``` 84 | -------------------------------------------------------------------------------- /dag.cabal: -------------------------------------------------------------------------------- 1 | Name: dag 2 | Version: 0.1.0.2 3 | Author: Athan Clark 4 | Maintainer: Athan Clark 5 | License: BSD3 6 | License-File: LICENSE 7 | Synopsis: Compile-time, type-safe directed acyclic graphs. 8 | Description: 9 | This is a type-safe approach for a directed acyclic graph. 10 | . 11 | Edge construction is incremental, creating a "schema": 12 | . 13 | > import Data.Graph.DAG.Edge 14 | > 15 | > -- | Edges are statically defined: 16 | > edges = 17 | > ECons (Edge :: EdgeValue "foo" "bar") $ 18 | > ECons (Edge :: EdgeValue "bar" "baz") $ 19 | > ECons (Edge :: EdgeValue "foo" "baz") 20 | > unique -- ENil, but casted for uniquely edged graphs 21 | . 22 | The nodes are separate from edges; graph may be not connected: 23 | . 24 | > data Cool = AllRight 25 | > | Radical 26 | > | SuperDuper 27 | > 28 | > nodes = 29 | > nadd "foo" AllRight $ 30 | > nadd "bar" Radical $ 31 | > nadd "baz" SuperDuper $ 32 | > nempty 33 | . 34 | Some type tomfoolery: 35 | . 36 | > *Data.Graph.DAG> :t edges 37 | > 38 | > edges 39 | > :: EdgeSchema 40 | > '['EdgeType "foo" "bar", 'EdgeType "bar" "baz", 41 | > 'EdgeType "foo" "baz"] -- Type list of edges 42 | > '['("foo", '["bar", "baz"]), '("bar", '["baz"])] -- potential loops 43 | > 'True -- uniqueness 44 | > 45 | > *Data.Graph.DAG> :t getSpanningTrees $ edges 46 | > 47 | > getSpanningTrees $ edges 48 | > :: Data.Proxy.Proxy 49 | > '['Node "foo" '['Node "bar" '['Node "baz" '[]] 50 | > ,'Node "baz" '[]] 51 | > ,'Node "bar" '['Node "baz" '[]] 52 | > ,'Node "baz" '[]] 53 | > 54 | > *Data.Graph.DAG> reflect $ getSpanningTrees $ edges 55 | > 56 | > [Node "foo" [Node "bar" [Node "baz" []] 57 | > ,Node "baz" []] 58 | > ,Node "bar" [Node "baz" []] 59 | > ,Node "baz" []] 60 | . 61 | We can also look at the edges, first-class: 62 | . 63 | > *Data.Graph.DAG> fcEdges edges 64 | > 65 | > [("foo","bar"),("foo","baz"),("bar","baz")] 66 | . 67 | Note that a @NodeSchema@'s keys don't have to be in-sync with it's paired 68 | @EdgeSchema@. After we have both, we can construct a @DAG@: 69 | . 70 | > graph = DAG edges nodes 71 | . 72 | Now we can do fun things, like get the spanning tree of a node: 73 | . 74 | > *Data.Graph.DAG> gtree "foo" graph 75 | > 76 | > Just (AllRight :@-> [Radical :@-> [SuperDuper :@-> []] 77 | > ,SuperDuper :@-> []]) 78 | . 79 | This library is still very naive, but it will give us compile-time enforcement 80 | of acyclicity (and uniqueness) in these graphs - ideal for dependency graphs. 81 | . 82 | The main deficiency of this graph is that our @EdgeSchema@ can't be 83 | /deconstructed/ soundly - there is just too much information loss between the 84 | value and type levels. This means we can't delete edges or look inside, but we 85 | can still add edges or work with the resulting structure. 86 | 87 | Cabal-Version: >= 1.10 88 | Build-Type: Simple 89 | 90 | Library 91 | Default-Language: Haskell2010 92 | HS-Source-Dirs: src 93 | GHC-Options: -Wall 94 | Exposed-Modules: Data.Graph.DAG 95 | Data.Graph.DAG.Edge 96 | Data.Graph.DAG.Edge.Utils 97 | Data.Graph.DAG.Node 98 | Build-Depends: base >= 4.7 && < 5 99 | , constraints 100 | , singletons 101 | 102 | Test-Suite spec 103 | Type: exitcode-stdio-1.0 104 | Default-Language: Haskell2010 105 | Hs-Source-Dirs: src 106 | , test 107 | Ghc-Options: -Wall 108 | Main-Is: Spec.hs 109 | Build-Depends: base 110 | , hspec 111 | , QuickCheck 112 | , quickcheck-instances 113 | 114 | Source-Repository head 115 | Type: git 116 | Location: https://github.com/athanclark/dag 117 | -------------------------------------------------------------------------------- /src/Data/Graph/DAG/Edge.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE BangPatterns #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE ConstraintKinds #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE FunctionalDependencies #-} 15 | 16 | module Data.Graph.DAG.Edge where 17 | 18 | import Data.Constraint 19 | import GHC.TypeLits 20 | import Data.Proxy 21 | 22 | -- | We use promoted symbol values for the @from@ and @to@ type parameters. This 23 | -- is the user-level data type when declaring the list of edges. 24 | data EdgeValue (from :: Symbol) (to :: Symbol) = Edge 25 | 26 | -- | We need this for type-level computation list. 27 | data EdgeKind = forall from to. EdgeType from to 28 | 29 | -- | Some people just want to watch the world burn. Ideally, this shouldn't 30 | -- exist; poor error messages, and is very square peg - round hole. 31 | type family Deducible (x :: Bool) :: Constraint where 32 | Deducible 'True = () 33 | 34 | -- | @not . elem@ for lists of types, resulting in a constraint. 35 | type family Excluding (x :: k) (xs :: Maybe [k]) :: Constraint where 36 | Excluding a ('Just '[]) = Deducible 'True -- Basis 37 | Excluding a 'Nothing = Deducible 'True -- Basis 38 | Excluding a ('Just (a ': ts)) = Deducible 'False -- Reject & Refute 39 | Excluding a ('Just (b ': ts)) = Excluding a ('Just ts) -- continue 40 | 41 | -- | A simple @Data.List.lookup@ function for type maps. 42 | type family Lookup (index :: k) ( map :: [(k, k2)] ) :: Maybe k2 where 43 | Lookup a ( '( a, v) ': xs ) = 'Just v 44 | Lookup a (b ': xs) = Lookup a xs 45 | Lookup a '[] = 'Nothing 46 | 47 | -- | Trivial inequality for non-reflexivity of edges 48 | type family (x :: k1) =/= (y :: k2) :: Constraint where 49 | a =/= a = Deducible 'False 50 | a =/= b = Deducible 'True 51 | 52 | -- | Simply reject anything that's been reached in the other direction. We 53 | -- expect an explicit type signature when uniqueness is needed, otherwise we 54 | -- will wait until invocation to see if the edges are unique. 55 | class Acceptable (a :: EdgeKind) 56 | ( oldLoops :: [(Symbol, [Symbol])] ) 57 | (unique :: Bool) where 58 | instance ( Excluding from (Lookup to excludeMap) 59 | , from =/= to ) => 60 | Acceptable ('EdgeType from to) excludeMap 'False where 61 | instance ( Excluding from (Lookup to excludeMap) 62 | , Excluding to (Lookup from excludeMap) 63 | , from =/= to ) => 64 | Acceptable ('EdgeType from to) excludeMap 'True where 65 | 66 | -- | Add an explicit element to the head of a list, if the test is inside that 67 | -- list. 68 | type family PrependIfElem (test :: k) (a :: k) (xs :: [k]) :: [k] where 69 | PrependIfElem t a (t ': xs) = a ': t ': xs 70 | PrependIfElem t a (u ': xs) = u ': (PrependIfElem t a xs) 71 | PrependIfElem t a '[] = '[] 72 | 73 | -- | Update the exclusion map with the new edge: the @from@ key gets @to@ added, 74 | -- likewise with keys that have @from@ in it's value list. We need to track if 75 | -- the key exists yet. 76 | type family DisallowIn 77 | (new :: EdgeKind) 78 | ( oldLoops :: [(Symbol, [Symbol])] ) 79 | (keyFoundYet :: Bool) :: [(Symbol, [Symbol])] where 80 | -- When @from ~ key@: 81 | DisallowIn ('EdgeType from to) ( '(from, xs) ': es) 'False = 82 | '(from, (to ': xs)) ': -- add @to@ to transitive reach list 83 | (DisallowIn ('EdgeType from to) es 'True) -- continue 84 | -- When @from ~/~ key@, and @from ~/~ head value@ 85 | DisallowIn ('EdgeType from to) ( '(key, vs) ': es ) keyFoundYet = 86 | '(key, (PrependIfElem from to vs)) ': -- find the needle if it exists 87 | (DisallowIn ('EdgeType from to) es keyFoundYet) -- continue 88 | -- Basis 89 | DisallowIn a '[] 'True = '[] -- search over. 90 | -- Growth via append 91 | DisallowIn ('EdgeType from to) '[] 'False = ('(from, (to ': '[])) ': '[]) 92 | 93 | -- | @edges@ is a list of types with kind @EdgeKind@, while @nearLoops@ is a 94 | -- map of the nodes transitively reachable by each node. 95 | data EdgeSchema (edges :: [EdgeKind]) 96 | (nearLoops :: [(Symbol, [Symbol])]) 97 | (unique :: Bool) where 98 | ENil :: EdgeSchema '[] '[] unique 99 | ECons :: ( Acceptable b oldLoops unique 100 | , EdgeValue from to ~ a 101 | , EdgeType from to ~ b 102 | , DisallowIn b oldLoops 'False ~ c 103 | ) => !a 104 | -> !(EdgeSchema old oldLoops unique) 105 | -> EdgeSchema (b ': old) c unique 106 | 107 | -- | Utility for constructing an @EdgeSchema@ incrementally without a type 108 | -- signature. 109 | unique :: EdgeSchema '[] '[] 'True 110 | unique = ENil 111 | 112 | notUnique :: EdgeSchema '[] '[] 'False 113 | notUnique = ENil 114 | -------------------------------------------------------------------------------- /src/Data/Graph/DAG/Edge/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | module Data.Graph.DAG.Edge.Utils where 15 | 16 | import Data.Graph.DAG.Edge 17 | 18 | import GHC.TypeLits 19 | import Data.Singletons.TH 20 | import Data.Singletons.Prelude 21 | import Data.Proxy 22 | import Data.Monoid 23 | import Data.Foldable (Foldable (foldMap)) 24 | import Control.Applicative 25 | 26 | -- | Trivial rose tree for creating spanning trees. We make control structure 27 | -- instances "parallel" (instead of cartesian) by default for simplicity. 28 | $(singletons [d| 29 | data RTree a = a :@-> [RTree a] deriving (Show, Eq, Functor) 30 | |]) 31 | 32 | instance Applicative RTree where 33 | pure a = a :@-> [] 34 | (f :@-> fs) <*> (x :@-> xs) = (f x) :@-> 35 | (zipWith (<*>) fs xs) 36 | 37 | instance Monad RTree where 38 | return = pure 39 | (x :@-> xs) >>= f = case f x of -- Substitution based instance. 40 | (y :@-> ys) -> y :@-> (fmap (>>= f) xs) 41 | 42 | instance Monoid a => Monoid (RTree a) where 43 | mempty = mempty :@-> [] 44 | (x :@-> xs) `mappend` (y :@-> ys) = (x `mappend` y) :@-> 45 | (zipWith mappend xs ys) 46 | 47 | instance Foldable RTree where 48 | foldMap f (x :@-> xs) = f x <> foldMap (foldMap f) xs 49 | 50 | -- | Gives us a generic way to get our spanning trees of the graph, as a value. 51 | -- Credit goes to . 52 | reflect :: 53 | forall (a :: k). 54 | (SingI a, SingKind ('KProxy :: KProxy k)) => 55 | Proxy a -> Demote a 56 | reflect _ = fromSing (sing :: Sing a) 57 | 58 | -- | Adds an empty @c@ tree to the list of trees uniquely 59 | type family AppendIfNotElemTrees (c :: k) (trees :: [RTree k]) :: [RTree k] where 60 | AppendIfNotElemTrees c ((c :@-> xs) ': xss) = (c :@-> xs) ': xss 61 | AppendIfNotElemTrees c ((x :@-> xs) ': xss) = (x :@-> xs) ': 62 | (AppendIfNotElemTrees c xss) 63 | AppendIfNotElemTrees c '[] = (c :@-> '[]) ': '[] 64 | 65 | -- | Adds @c@ as a child of any tree with a root @t@. Assumes unique roots. 66 | type family AddChildTo (test :: k) 67 | (child :: k) 68 | (trees :: [RTree k]) :: [RTree k] where 69 | AddChildTo t c ((t :@-> xs) ': xss) = 70 | (t :@-> (AppendIfNotElemTrees c xs)) ': (AddChildTo t c xss) 71 | AddChildTo t c ((x :@-> xs) ': xss) = 72 | (x :@-> (AddChildTo t c xs)) ': (AddChildTo t c xss) 73 | AddChildTo t c '[] = '[] 74 | 75 | -- | We need to track if @from@ has is a root node or not. TODO: Some code repeat. 76 | type family AddEdge' (edge :: EdgeKind) 77 | (trees :: [RTree Symbol]) 78 | (hasFromRoot :: Bool) 79 | (hasToRoot :: Bool):: [RTree Symbol] where 80 | AddEdge' ('EdgeType from to) '[] 'False 'False = 81 | (from :@-> ((to :@-> '[]) ': '[])) ': (to :@-> '[]) ': '[] 82 | 83 | AddEdge' ('EdgeType from to) '[] 'True 'False = 84 | (to :@-> '[]) ': '[] 85 | 86 | AddEdge' ('EdgeType from to) '[] 'False 'True = 87 | (from :@-> ((to :@-> '[]) ': '[])) ': '[] 88 | 89 | AddEdge' x '[] 'True 'True = '[] 90 | 91 | AddEdge' ('EdgeType from to) ((from :@-> xs) ': xss) hasFromRoot hasToRoot = 92 | (from :@-> (AppendIfNotElemTrees to xs)) ': 93 | (AddEdge' ('EdgeType from to) xss 'True hasToRoot) 94 | 95 | AddEdge' ('EdgeType from to) ((to :@-> xs) ': xss) hasFromRoot hasToRoot = 96 | (to :@-> (AddEdge' ('EdgeType from to) xs 'True 'True)) ': 97 | (AddEdge' ('EdgeType from to) xss hasFromRoot 'True) 98 | 99 | -- Go downward, and laterally (I think). 100 | AddEdge' ('EdgeType from to) ((x :@-> xs) ': xss) hasFromRoot hasToRoot = 101 | (x :@-> (AddEdge' ('EdgeType from to) xs 'True 'True)) ': 102 | (AddEdge' ('EdgeType from to) xss hasFromRoot hasToRoot) 103 | 104 | -- | Add @to@ as a child to every @from@ node in the accumulator. 105 | type family AddEdge (edge :: EdgeKind) 106 | (trees :: [RTree Symbol]) :: [RTree Symbol] where 107 | AddEdge a trees = AddEdge' a trees 'False 'False 108 | 109 | -- | Auxilliary function normally defined in a @where@ clause for manual folding. 110 | type family SpanningTrees' (edges :: [EdgeKind]) 111 | (acc :: [RTree Symbol]) :: [RTree Symbol] where 112 | SpanningTrees' '[] trees = trees 113 | SpanningTrees' (('EdgeType from to) ': es) trees = 114 | SpanningTrees' es (AddEdge ('EdgeType from to) trees) 115 | 116 | -- | Expects edges to already be type-safe 117 | type family SpanningTrees (edges :: [EdgeKind]) :: [RTree Symbol] where 118 | SpanningTrees edges = SpanningTrees' edges '[] 119 | 120 | getSpanningTrees :: EdgeSchema es x unique -> Proxy (SpanningTrees es) 121 | getSpanningTrees _ = Proxy 122 | 123 | -- | Get the spanning trees of an @EdgeSchema@. Operate on the assumtion that 124 | -- the data returned is actually @[Tree String]@. 125 | espanningtrees :: SingI (SpanningTrees' es '[]) => 126 | EdgeSchema es x unique 127 | -> Demote (SpanningTrees' es '[]) 128 | espanningtrees = reflect . getSpanningTrees 129 | 130 | -- | Get a single tree. 131 | etree :: SingI (SpanningTrees' es '[]) => 132 | String -> EdgeSchema es x unique -> Maybe (RTree String) 133 | etree k es = getTree k $ espanningtrees es 134 | where 135 | getTree k1 ( n@(k2 :@-> xs) : ns ) | k1 == k2 = Just n 136 | | otherwise = getTree k1 ns 137 | getTree _ [] = Nothing 138 | 139 | -- | Degenerate (but type-safe!) @head@. 140 | ehead :: ( EdgeType from to ~ b 141 | , EdgeValue from to ~ a 142 | ) => EdgeSchema (b ': old) c u -> a 143 | ehead _ = Edge 144 | 145 | -- | For now, we only suport unique edges. 146 | eTreeToEdges :: RTree String -> [(String,String)] 147 | eTreeToEdges = treeToEdges' [] 148 | where 149 | treeToEdges' :: [(String,String)] 150 | -> RTree String 151 | -> [(String,String)] 152 | treeToEdges' zs (_ :@-> []) = zs 153 | treeToEdges' zs (x :@-> xs) = 154 | let newEdges = umerge zs $ map (\q -> (x, getNodeVal q)) xs 155 | in 156 | foldl treeToEdges' newEdges xs 157 | getNodeVal (x :@-> _) = x 158 | -- unique merge 159 | umerge [] ys = ys 160 | umerge (x:xs) ys | x `elem` ys = umerge xs ys 161 | | otherwise = x : umerge xs ys 162 | 163 | -- | Get a first-class list of edges from spanning trees. Only works on uniqely 164 | -- edged @EdgeSchema@'s. 165 | eForestToEdges :: [RTree String] -> [(String,String)] 166 | eForestToEdges xs = foldl (\es t -> umerge es $ eTreeToEdges t) [] xs 167 | where 168 | -- unique merge 169 | umerge [] ys = ys 170 | umerge (x:xs) ys | x `elem` ys = umerge xs ys 171 | | otherwise = x : umerge xs ys 172 | 173 | -- | Get the "First-Class" edges of a uniquely-edged @EdgeSchema@. 174 | fcEdges :: SingI (SpanningTrees' es '[]) => 175 | EdgeSchema es x 'True -> [(String, String)] 176 | fcEdges = eForestToEdges . espanningtrees 177 | 178 | -- eflip e = espanningtrees e 179 | --------------------------------------------------------------------------------