├── .gitignore ├── poly-graph-persistent ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── poly-graph-persistent.cabal ├── src │ └── Data │ │ └── Graph │ │ └── HGraph │ │ ├── Persistent.hs │ │ └── Persistent │ │ ├── Instances.hs │ │ └── TH.hs └── test │ ├── Spec.hs │ └── Spec2.hs ├── poly-graph ├── LICENSE ├── README.md ├── Setup.hs ├── poly-graph.cabal ├── src │ └── Data │ │ └── Graph │ │ ├── HGraph.hs │ │ └── HGraph │ │ ├── Instances.hs │ │ ├── Internal.hs │ │ └── TH.hs └── test │ └── Spec.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | TAGS -------------------------------------------------------------------------------- /poly-graph-persistent/.gitignore: -------------------------------------------------------------------------------- 1 | test/testdb.sqlite3 -------------------------------------------------------------------------------- /poly-graph-persistent/LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Eric Easley 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /poly-graph-persistent/README.md: -------------------------------------------------------------------------------- 1 | # poly-graph 2 | 3 | This is a library for polymorphic (i.e. nodes do not all have to be of the same type) directed acyclic graphs. 4 | 5 | To get a sense of how to construct such graphs, look in the tests. 6 | -------------------------------------------------------------------------------- /poly-graph-persistent/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /poly-graph-persistent/poly-graph-persistent.cabal: -------------------------------------------------------------------------------- 1 | name: poly-graph-persistent 2 | version: 0.1.0.0 3 | synopsis: Special support for using `poly-graph` with `persistent` 4 | description: Please see README.md 5 | homepage: http://github.com/pseudonom/poly-graph 6 | license: MIT 7 | license-file: LICENSE 8 | author: Eric Easley 9 | maintainer: eric101111@gmail.com 10 | copyright: 2016 Eric Easley 11 | category: Database 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Data.Graph.HGraph.Persistent 19 | , Data.Graph.HGraph.Persistent.Instances 20 | , Data.Graph.HGraph.Persistent.TH 21 | build-depends: base >= 4.7 && < 5 22 | , poly-graph 23 | , transformers 24 | , persistent 25 | , persistent-template 26 | , tagged 27 | , generics-eot 28 | , QuickCheck 29 | , lens 30 | , semigroups 31 | , text 32 | , containers 33 | , template-haskell 34 | default-language: Haskell2010 35 | 36 | test-suite test 37 | type: exitcode-stdio-1.0 38 | hs-source-dirs: test 39 | main-is: Spec.hs 40 | build-depends: base 41 | , poly-graph 42 | , poly-graph-persistent 43 | , hspec 44 | , persistent 45 | , persistent-template 46 | , transformers 47 | , monad-logger 48 | , resourcet 49 | , persistent-postgresql 50 | , fast-logger 51 | , QuickCheck 52 | , shakespeare 53 | , text 54 | , lens 55 | , bytestring 56 | , tagged 57 | , vector-sized 58 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 59 | default-language: Haskell2010 60 | 61 | test-suite presentation 62 | type: exitcode-stdio-1.0 63 | hs-source-dirs: test 64 | main-is: Spec2.hs 65 | build-depends: base 66 | , poly-graph 67 | , poly-graph-persistent 68 | , hspec 69 | , persistent 70 | , persistent-template 71 | , transformers 72 | , monad-logger 73 | , resourcet 74 | , persistent-postgresql 75 | , fast-logger 76 | , QuickCheck 77 | , text 78 | , lens 79 | , bytestring 80 | , tagged 81 | , time 82 | , shakespeare 83 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 84 | default-language: Haskell2010 85 | 86 | source-repository head 87 | type: git 88 | location: https://github.com/pseudonom/poly-graph 89 | -------------------------------------------------------------------------------- /poly-graph-persistent/src/Data/Graph/HGraph/Persistent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE PatternSynonyms #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TupleSections #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | -- Pattern synonyms and exhaustivity checking don't work well together 15 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 16 | {-# OPTIONS_GHC -fno-warn-orphans #-} 17 | 18 | module Data.Graph.HGraph.Persistent where 19 | 20 | import Control.Lens (partsOf, (^..), (%%~)) 21 | import Control.Monad.Trans.Reader (ReaderT) 22 | import Control.Monad.IO.Class (MonadIO, liftIO) 23 | import Data.Foldable (traverse_, toList) 24 | import qualified Data.List as List 25 | import Data.Proxy 26 | import Database.Persist 27 | import Generics.Eot (Eot, HasEot) 28 | import GHC.TypeLits hiding (TypeError) 29 | import Test.QuickCheck (vector) 30 | import Test.QuickCheck.Arbitrary (Arbitrary(..)) 31 | import Test.QuickCheck.Gen (generate, Gen) 32 | 33 | import Data.Graph.HGraph 34 | import Data.Graph.HGraph.Instances 35 | import Data.Graph.HGraph.Internal 36 | import Data.Graph.HGraph.Persistent.TH (UniquenessCheck(..)) 37 | 38 | instance 39 | Key a `FieldPointsAt` Entity a where 40 | _ `fieldPointsAt` (Entity k _) = k 41 | instance 42 | Maybe (Key a) `FieldPointsAt` Maybe (Entity a) where 43 | _ `fieldPointsAt` Just (Entity k _) = Just k 44 | _ `fieldPointsAt` Nothing = Nothing 45 | instance 46 | Maybe (Key a) `FieldPointsAt` Entity a where 47 | _ `fieldPointsAt` (Entity k _) = Just k 48 | instance 49 | {-# OVERLAPPABLE #-} 50 | a `FieldPointsAt` b where 51 | fieldPointsAt = const 52 | 53 | type family TypeError (b :: k) (msg :: Symbol) (a :: k) :: j 54 | 55 | instance 56 | {-# OVERLAPPING #-} 57 | Nullify pointedFrom (Maybe (Key a)) where 58 | nullify Proxy = const Nothing 59 | instance 60 | {-# OVERLAPPING #-} 61 | (TypeError pointedFrom " is missing pointer to " a) => 62 | Nullify pointedFrom (Key a) where 63 | nullify Proxy = id 64 | instance 65 | {-# OVERLAPPABLE #-} 66 | Nullify pointedFrom pointedTo where 67 | nullify Proxy = id 68 | 69 | type instance HandleLeft Entity = "Entity" 70 | 71 | _entityVal :: Lens' (Entity a) a 72 | _entityVal pure' (Entity i e) = (\e' -> Entity i e') <$> pure' e 73 | 74 | instance (Base a ~ a) => ToBase (Entity a) where 75 | base = _entityVal 76 | 77 | instance (a `DispatchOnTyCons` b) => PointsAtInternal "Entity" (Entity a) b where 78 | pointsAtInternal Proxy (Entity i a) b = Entity i $ a `pointsAtDispatcher` b 79 | instance (a `PointsAt` Entity b) => PointsAtInternal "NoTyCon" a (Entity b) where 80 | pointsAtInternal Proxy a b = a `pointsAt` b 81 | 82 | class InsertEntityGraph a backend baseBackend | a -> baseBackend where 83 | insertEntityGraph :: 84 | (MonadIO m, PersistStoreWrite backend) => 85 | HGraph a -> ReaderT backend m () 86 | 87 | -- | HGraph base case (can't be the empty list because then we won't know which type of @backend@ to use) 88 | instance 89 | (InsertEntityElement a backend baseBackend, BaseBackend backend ~ baseBackend) => 90 | InsertEntityGraph '[ '(i, is, a)] backend baseBackend where 91 | insertEntityGraph (Node a `Cons` Nil) = insertEntityElement a 92 | -- | HGraph recursive case 93 | instance 94 | (InsertEntityElement a backend baseBackend, InsertEntityGraph (b ': c) backend baseBackend, BaseBackend backend ~ baseBackend) => 95 | InsertEntityGraph ('(i, is, a) ': b ': c) backend baseBackend where 96 | insertEntityGraph (Node a `Cons` b) = insertEntityGraph b >> insertEntityElement a 97 | 98 | 99 | class InsertEntityElement a backend baseBackend | a -> baseBackend where 100 | insertEntityElement :: 101 | (MonadIO m) => 102 | a -> ReaderT backend m () 103 | 104 | instance 105 | (PersistEntityBackend a ~ baseBackend, BaseBackend backend ~ baseBackend, PersistStoreWrite backend) => 106 | InsertEntityElement (Entity a) backend baseBackend where 107 | insertEntityElement (Entity key val) = insertKey key val 108 | instance 109 | (Traversable f, PersistEntityBackend a ~ baseBackend, BaseBackend backend ~ baseBackend, PersistStoreWrite backend) => 110 | InsertEntityElement (f (Entity a)) backend baseBackend where 111 | insertEntityElement = traverse_ (\(Entity key val) -> insertKey key val) 112 | 113 | 114 | type family Unwrap (a :: *) :: * where 115 | Unwrap (Entity a) = a 116 | Unwrap (f (Entity a)) = f a 117 | type family UnwrapAll (as :: [(k, [k], *)]) :: [(k, [k], *)] where 118 | UnwrapAll ('(i, is, a) ': as) = '(i, is, Unwrap a) ': UnwrapAll as 119 | UnwrapAll '[] = '[] 120 | 121 | insertGraph :: 122 | (MonadIO m, InsertGraph '[] (UnwrapAll b) b backend baseBackend, BaseBackend backend ~ baseBackend) => 123 | HGraph (UnwrapAll b) -> ReaderT backend m (HGraph b) 124 | insertGraph = insertGraph' (Proxy :: Proxy ('[] :: [*])) 125 | 126 | class 127 | (BaseBackend backend ~ baseBackend, PersistStoreWrite backend) => 128 | InsertGraph (ps :: [*]) (a :: [(k, [k], *)]) (b :: [(k, [k], *)]) (backend :: *) (baseBackend :: *) 129 | | a -> b, b -> a, a -> baseBackend , b -> baseBackend where 130 | insertGraph' :: 131 | (MonadIO m, UnwrapAll b ~ a) => 132 | Proxy ps -> HGraph a -> ReaderT backend m (HGraph b) 133 | 134 | -- | HGraph base case (can't be the empty list because then we won't know which type of @backend@ to use) 135 | instance 136 | ( InsertElement a b backend baseBackend, HasEot a, GNullify a ps (Eot a) 137 | , PointsAtR i is a '[] 138 | , BaseBackend backend ~ baseBackend 139 | , PersistStoreWrite backend 140 | ) => 141 | InsertGraph ps '[ '(i, is, a)] '[ '(i, is, b)] backend baseBackend where 142 | insertGraph' Proxy (rawNode `Cons` Nil) = do 143 | let Node updated = rawNode `pointsAtR` Nil 144 | inserted <- insertElement updated 145 | pure $ Node inserted `Cons` Nil 146 | 147 | -- | HGraph recursive case 148 | instance 149 | ( (i `Member` (e ': f)) ~ 'UniqueName 150 | , PointsAtR i is a (e ': f) 151 | , InsertGraph ps (b ': c) (e ': f) backend baseBackend 152 | , InsertElement a d backend baseBackend 153 | ) => 154 | InsertGraph ps ('(i, is, a) ': b ': c) ('(i, is, d) ': e ': f) backend baseBackend where 155 | insertGraph' Proxy (rawNode `Cons` rawGraph) = do 156 | graph <- insertGraph' (Proxy :: Proxy ps) rawGraph 157 | let Node updated = rawNode `pointsAtR` graph 158 | inserted <- insertElement updated 159 | pure $ Node inserted `Cons` graph 160 | 161 | class 162 | InsertElement (a :: *) (b :: *) (backend :: *) (baseBackend :: *) | a -> b, b -> a, a -> baseBackend, b -> baseBackend where 163 | insertElement :: 164 | (MonadIO m, Unwrap b ~ a) => 165 | a -> ReaderT backend m b 166 | instance 167 | (PersistEntity a, PersistEntityBackend a ~ baseBackend, BaseBackend backend ~ baseBackend, PersistStoreWrite backend) => 168 | InsertElement a (Entity a) backend baseBackend where 169 | insertElement a = flip Entity a <$> insert a 170 | instance 171 | (PersistEntity a, Traversable f, Applicative f, PersistEntityBackend a ~ baseBackend, BaseBackend backend ~ baseBackend, PersistStoreWrite backend) => 172 | InsertElement (f a) (f (Entity a)) backend baseBackend where 173 | insertElement fa = do 174 | fid <- traverse insert fa 175 | pure $ Entity <$> fid <*> fa 176 | 177 | insertGraphFromFragments 178 | :: 179 | ( MonadIO m 180 | , Arbitrary (RawGraph z) 181 | , z ~ UnwrapAll y 182 | , InsertGraph '[] z y backend baseBackend 183 | , PersistStoreWrite backend 184 | , BaseBackend backend ~ baseBackend 185 | ) 186 | => Proxy y 187 | -> (HGraph z -> HGraph z) 188 | -> ReaderT backend m (HGraph z, HGraph y) 189 | insertGraphFromFragments Proxy f = do 190 | graph <- liftIO (f . unRawGraph <$> generate arbitrary) 191 | (graph,) <$> insertGraph graph 192 | 193 | insertUniqueGraphFromFragments 194 | :: 195 | ( MonadIO m 196 | , Arbitrary (RawGraph z) 197 | , z ~ UnwrapAll y 198 | , WrapAll z ~ y 199 | , EnsureGraphUniqueness '[] z y 200 | , InsertGraph '[] z y backend baseBackend 201 | , PersistStoreWrite backend 202 | , BaseBackend backend ~ baseBackend 203 | ) 204 | => Proxy y 205 | -> (HGraph z -> HGraph z) 206 | -> ReaderT backend m (HGraph z, HGraph y) 207 | insertUniqueGraphFromFragments Proxy f = do 208 | graph <- liftIO (f <$> generate (ensureGraphUniqueness =<< fmap unRawGraph arbitrary)) 209 | (graph,) <$> insertGraph graph 210 | 211 | -- Handy helper function for ensuring that a graph is unique in some attribute (e.g. email address) 212 | unique :: (Eq c, SetAllOfType a b, GetAllOfType a b, Arbitrary c) => Lens' b c -> HGraph a -> Gen (HGraph a) 213 | unique field graph = do 214 | if anySame (graph ^.. allOfType . field) 215 | then do 216 | -- Weirdly, switching this to `(=<<)` stops it from type checking 217 | graph' <- graph & partsOf (allOfType . field) %%~ vector . length 218 | unique field graph' 219 | else pure graph 220 | where 221 | anySame xs = length (List.nub xs) /= length xs 222 | 223 | type family Wrap (a :: *) :: * where 224 | Wrap (f a) = f (Entity a) 225 | Wrap a = Entity a 226 | 227 | type family WrapAll (as :: [(k, [k], *)]) :: [(k, [k], *)] where 228 | WrapAll ('(i, is, a) ': as) = '(i, is, Wrap a) ': WrapAll as 229 | WrapAll '[] = '[] 230 | 231 | ensureGraphUniqueness 232 | :: (EnsureGraphUniqueness '[] a (WrapAll a)) 233 | => HGraph a 234 | -> Gen (HGraph a) 235 | ensureGraphUniqueness = ensureGraphUniqueness' (Proxy :: Proxy ('[] :: [*])) 236 | 237 | class 238 | EnsureGraphUniqueness (ps :: [*]) (a :: [(k, [k], *)]) (b :: [(k, [k], *)]) | a -> b, b -> a where 239 | ensureGraphUniqueness' :: (WrapAll a ~ b) => Proxy ps -> HGraph a -> Gen (HGraph a) 240 | 241 | instance EnsureGraphUniqueness ps '[] '[] where 242 | ensureGraphUniqueness' Proxy Nil = pure Nil 243 | 244 | instance 245 | ( (i `Member` as) ~ 'UniqueName 246 | , EnsureGraphUniqueness ps as bs 247 | , EnsureUniqueness a b as 248 | ) => 249 | EnsureGraphUniqueness ps ('(i, is, a) ': as) ('(i, is, b) ': bs) where 250 | ensureGraphUniqueness' Proxy (Node item `Cons` graph) = do 251 | uniquedGraph <- ensureGraphUniqueness' (Proxy :: Proxy ps) graph 252 | uniqueItem <- ensureUniqueness item uniquedGraph 253 | pure $ Node uniqueItem `Cons` uniquedGraph 254 | 255 | -- | Update a to be unique in HGraph as 256 | class EnsureUniqueness a b as | a -> b, b -> a where 257 | ensureUniqueness :: (Wrap a ~ b) => a -> HGraph as -> Gen a 258 | 259 | -- | Check uniqueness for a by its Uniques modulo FKs 260 | instance 261 | ( PersistEntity a 262 | , GetAllOfType as a 263 | , Arbitrary a 264 | , UniquenessCheck a 265 | ) => EnsureUniqueness a (Entity a) as where 266 | ensureUniqueness a0 graph = 267 | loop (getAllOfType graph) a0 268 | where 269 | loop others a 270 | | any (couldCauseUniquenessViolation a) others = arbitrary >>= loop others 271 | | otherwise = pure a 272 | 273 | -- | Check uniqueness by looking inside Functor-shaped values and ensuring 274 | -- that the values in the Functor itself are unique together 275 | instance 276 | ( Wrap a ~ Entity a 277 | , Traversable f 278 | , EnsureUniqueness a (Entity a) as 279 | , DoesNodeSatisfyUniqueness (f a) (f (Entity a)) 280 | , Arbitrary a 281 | ) => EnsureUniqueness (f a) (f (Entity a)) as where 282 | ensureUniqueness fa graph = do 283 | fa' <- traverse (`ensureUniqueness` graph) fa 284 | if doesNodeSatisfyUniqueness fa' 285 | then pure fa' 286 | else do 287 | fa'' <- traverse (const arbitrary) fa' -- This could be less drastic 288 | ensureUniqueness fa'' graph 289 | 290 | -- | Check that a context-free value is internally consistent 291 | class DoesNodeSatisfyUniqueness a b | a -> b, b -> a where 292 | doesNodeSatisfyUniqueness :: a -> Bool 293 | 294 | -- | Collections of entities should not have duplicates 295 | instance 296 | ( Foldable f 297 | , PersistEntity a 298 | , UniquenessCheck a 299 | ) => DoesNodeSatisfyUniqueness (f a) (f (Entity a)) where 300 | doesNodeSatisfyUniqueness fa = 301 | length (List.nubBy couldCauseUniquenessViolation items) == length items 302 | where 303 | items = toList fa 304 | -------------------------------------------------------------------------------- /poly-graph-persistent/src/Data/Graph/HGraph/Persistent/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Data.Graph.HGraph.Persistent.Instances where 6 | 7 | import Database.Persist.Sql 8 | import Test.QuickCheck.Arbitrary (Arbitrary(..)) 9 | 10 | instance (ToBackendKey SqlBackend a) => Arbitrary (Key a) where 11 | arbitrary = toSqlKey <$> arbitrary 12 | instance (PersistEntity a, Arbitrary (Key a), Arbitrary a) => Arbitrary (Entity a) where 13 | arbitrary = Entity <$> arbitrary <*> arbitrary 14 | -------------------------------------------------------------------------------- /poly-graph-persistent/src/Data/Graph/HGraph/Persistent/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | 5 | module Data.Graph.HGraph.Persistent.TH 6 | ( UniquenessCheck(..) 7 | , mkUniquenessChecks 8 | , mkUniquenessCheck 9 | ) where 10 | 11 | import Control.Arrow ((&&&)) 12 | import Data.Char (toLower, toUpper) 13 | import Data.List.NonEmpty (nonEmpty) 14 | import Data.Map.Strict (Map) 15 | import qualified Data.Map.Strict as Map 16 | import Data.Maybe (mapMaybe) 17 | import Data.Monoid ((<>)) 18 | import Data.Text (Text, unpack, cons, uncons) 19 | import Database.Persist 20 | import Database.Persist.Quasi (nullable) 21 | import Database.Persist.TH 22 | import Language.Haskell.TH 23 | 24 | -- | 'couldCauseUniquenessViolation' returns 'True' if its arguments violate 25 | -- at least one uniqueness constraint on that type, ignoring foreign keys. 26 | class UniquenessCheck a where 27 | couldCauseUniquenessViolation :: a -> a -> Bool 28 | 29 | -- | Use 'mkUniquenessChecks' in 'Database.Persist.TH.share' with the same 30 | -- settings passed to 'Database.Persist.TH.mkPersist' to generate instances 31 | -- for 'UniquenessCheck'. For example: 32 | -- 33 | -- > share 34 | -- > [ mkUniquenessChecks sqlSettings 35 | -- > , mkPersist sqlSettings 36 | -- > , mkMigrate "migrate" 37 | -- > ] 38 | -- > [persistLowerCase| 39 | -- > Author 40 | -- > name Text 41 | -- > pseudonym Text Maybe 42 | -- > UniqueAuthorName name 43 | -- > UniqueAuthoPseudonym pseudonym !force 44 | -- > deriving Show Eq Generic 45 | -- > Book 46 | -- > title Text 47 | -- > authorId AuthorId 48 | -- > publicationDate Date 49 | -- > isbn ISBN 50 | -- > UniquePublicationInfo authorId title publicationDate 51 | -- > UniqueISBN isbn 52 | -- > deriving Show Eq Generic 53 | -- > |] 54 | -- 55 | -- This will generate the following 'UniquenessCheck' instances: 56 | -- 57 | -- > class UniquenessCheck Author where 58 | -- > couldCauseUniquenessViolation lhs rhs = 59 | -- > authorName lhs == authorName rhs == || 60 | -- > maybe False ((==) <$> pseudonym lhs <*> pseudonym rhs) 61 | -- > 62 | -- > class UniquenessCheck Book where 63 | -- > couldCauseUniquenessViolation lhs rhs = 64 | -- > bookTitle lhs == bookTitle rhs && 65 | -- > bookPublicationDate lhs == bookPublicationDate rhs || 66 | -- > bookIsbn lhs == bookIsbn rhs 67 | -- 68 | -- The format of each function body is roughly: 69 | -- 70 | -- > {- 71 | -- > orExpr = andExpr [|| orExpr] 72 | -- > 73 | -- > andExpr = comparison [&& andExpr] 74 | -- > 75 | -- > comparison 76 | -- > = nonNullComparison 77 | -- > | nullableComparison 78 | -- > 79 | -- > nonNullComparison = selector lhs == selector rhs 80 | -- > 81 | -- > nullableComparison = maybe False ((==) <$> selector lhs <*> selector rhs) 82 | -- > -} 83 | -- 84 | -- Note the difference in how non-null fields are compared versus how nullable 85 | -- fields are compared. In Haskell, 'Nothing' is equal to 'Nothing', but in SQL, 86 | -- NULL is not equal to NULL. 87 | -- 88 | -- Additionally the foreign keys aren't compared since they haven't been updated 89 | -- to actually point to other entities yet, so we can't rely on them contributing 90 | -- to uniqueness. 91 | mkUniquenessChecks :: MkPersistSettings -> [EntityDef] -> Q [Dec] 92 | mkUniquenessChecks settings = fmap concat . traverse (mkUniquenessCheck settings) 93 | 94 | mkUniquenessCheck :: MkPersistSettings -> EntityDef -> Q [Dec] 95 | mkUniquenessCheck settings def = do 96 | lhs <- newName "_lhs" 97 | rhs <- newName "_rhs" 98 | mkUniquenessCheckWithOperands settings def (lhs, rhs) 99 | 100 | mkUniquenessCheckWithOperands :: MkPersistSettings -> EntityDef -> (Name, Name) -> Q [Dec] 101 | mkUniquenessCheckWithOperands settings EntityDef{..} operands@(lhs, rhs) = 102 | [d| 103 | instance UniquenessCheck $typeName where 104 | couldCauseUniquenessViolation $(varP lhs) $(varP rhs) = $expr 105 | |] 106 | where 107 | unHaskelled = unHaskellName entityHaskell 108 | typeName = conT $ mkName $ unpack unHaskelled 109 | fieldMap = mkFieldMap entityFields 110 | 111 | expr = pure $ mkOrExpr mkSelector fieldMap operands entityUniques 112 | 113 | mkSelector = mkName . unpack . maybeUnderscore . maybePrefixed 114 | maybeUnderscore fieldName 115 | | mpsGenerateLenses settings = '_' `cons` fieldName 116 | | otherwise = fieldName 117 | maybePrefixed fieldName 118 | | mpsPrefixFields settings = lowerFirst unHaskelled <> upperFirst (unHaskellName fieldName) 119 | | otherwise = unHaskellName fieldName 120 | 121 | type FieldMap = Map HaskellName (ReferenceDef, IsNullable) 122 | 123 | mkFieldMap :: [FieldDef] -> FieldMap 124 | mkFieldMap = 125 | Map.fromList . map mkPair 126 | where 127 | mkPair FieldDef{..} = 128 | (fieldHaskell, (fieldReference, nullable fieldAttrs)) 129 | 130 | lowerFirst :: Text -> Text 131 | lowerFirst t = 132 | case uncons t of 133 | Just (c, cs) -> cons (toLower c) cs 134 | Nothing -> t 135 | 136 | upperFirst :: Text -> Text 137 | upperFirst t = 138 | case uncons t of 139 | Just (c, cs) -> cons (toUpper c) cs 140 | Nothing -> t 141 | 142 | mkOrExpr :: (HaskellName -> Name) -> FieldMap -> (Name, Name) -> [UniqueDef] -> Exp 143 | mkOrExpr mkSelector fieldMap operands uniqueDefs = 144 | maybe false (foldl1 $ binApp orOp) (nonEmpty andExprs) 145 | where 146 | false = ConE $ mkName "False" 147 | orOp = VarE $ mkName "||" 148 | andExprs = mapMaybe (mkAndExpr mkSelector fieldMap operands) uniqueDefs 149 | 150 | mkAndExpr :: (HaskellName -> Name) -> FieldMap -> (Name, Name) -> UniqueDef -> Maybe Exp 151 | mkAndExpr mkSelector fieldMap operands UniqueDef{..} = 152 | foldl1 (binApp andOp) <$> nonEmpty comparisons 153 | where 154 | andOp = VarE $ mkName "&&" 155 | fields = map fst uniqueFields 156 | nonForeignFields = mapMaybe (uncurry comparisonType . (id &&& (fieldMap Map.!))) fields 157 | comparisons = map (mkComparison mkSelector operands) nonForeignFields 158 | 159 | data ComparisonType 160 | = PlainEquality HaskellName 161 | | OnlyNonNull HaskellName 162 | 163 | comparisonType :: HaskellName -> (ReferenceDef, IsNullable) -> Maybe ComparisonType 164 | comparisonType name pair = 165 | case pair of 166 | (ForeignRef{}, _) -> Nothing 167 | (_, Nullable{}) -> pure (OnlyNonNull name) 168 | (_, NotNullable) -> pure (PlainEquality name) 169 | 170 | mkComparison :: (HaskellName -> Name) -> (Name, Name) -> ComparisonType -> Exp 171 | mkComparison mkSelector operands (PlainEquality name) = mkEqComparison operands (mkSelector name) 172 | mkComparison mkSelector operands (OnlyNonNull name) = mkNonNullEqComparison operands (mkSelector name) 173 | 174 | mkEqComparison :: (Name, Name) -> Name -> Exp 175 | mkEqComparison (lhs, rhs) selector = 176 | binApp 177 | (VarE $ mkName "==") 178 | (VarE selector `AppE` VarE lhs) 179 | (VarE selector `AppE` VarE rhs) 180 | 181 | mkNonNullEqComparison :: (Name, Name) -> Name -> Exp 182 | mkNonNullEqComparison (lhs, rhs) selector = 183 | VarE (mkName "maybe") 184 | `AppE` ConE (mkName "False") 185 | `AppE` VarE (mkName "id") 186 | `AppE` ParensE 187 | (binApp 188 | (VarE $ mkName "<*>") 189 | (binApp 190 | (VarE $ mkName "<$>") 191 | (VarE $ mkName "==") 192 | (VarE selector `AppE` VarE lhs)) 193 | (VarE selector `AppE` VarE rhs)) 194 | 195 | binApp :: Exp -> Exp -> Exp -> Exp 196 | binApp f x y = UInfixE x f y 197 | -------------------------------------------------------------------------------- /poly-graph-persistent/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE QuasiQuotes #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE StandaloneDeriving #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | {-# LANGUAGE ViewPatterns #-} 19 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 20 | {-# OPTIONS_GHC -fno-warn-orphans #-} 21 | 22 | import Test.Hspec 23 | 24 | import Control.Lens hiding ((:<), _head, _tail) 25 | import Control.Monad (void) 26 | import Control.Monad.IO.Class (MonadIO) 27 | import Control.Monad.Logger (LoggingT(..), runStderrLoggingT) 28 | import Control.Monad.IO.Class (liftIO) 29 | import Control.Monad.Trans.Reader (ReaderT) 30 | import Control.Monad.Trans.Resource (MonadBaseControl) 31 | import Data.Maybe (fromMaybe) 32 | import Data.Monoid (Endo) 33 | import Data.Proxy (Proxy(..)) 34 | import Data.Text (Text, pack) 35 | import qualified Data.Vector.Sized as Sized 36 | import Database.Persist 37 | import Database.Persist.Postgresql 38 | import Database.Persist.TH 39 | import GHC.Generics (Generic) 40 | import GHC.TypeLits (KnownNat, natVal) 41 | import Test.QuickCheck.Arbitrary (Arbitrary(..), vector) 42 | import Test.QuickCheck.Gen (generate, Gen) 43 | import Text.Shakespeare.Text (st) 44 | 45 | import Data.Graph.HGraph 46 | import Data.Graph.HGraph.Instances () 47 | import Data.Graph.HGraph.Persistent 48 | import Data.Graph.HGraph.Persistent.Instances () 49 | import Data.Graph.HGraph.Persistent.TH 50 | import Data.Graph.HGraph.TH 51 | 52 | connString :: ConnectionString 53 | connString = "host=localhost port=5432 user=test dbname=poly-graph password=test" 54 | 55 | runConn :: (MonadIO m, MonadBaseControl IO m) => SqlPersistT (LoggingT m) t -> m t 56 | runConn = runStderrLoggingT . withPostgresqlConn connString . runSqlConn 57 | 58 | db :: (MonadIO m, MonadBaseControl IO m) => SqlPersistT (LoggingT m) () -> m () 59 | db actions = runConn $ actions >> resetSequences >> transactionUndo 60 | 61 | resetSequences :: (MonadIO m) => SqlPersistT (LoggingT m) [Single Int] 62 | resetSequences = 63 | rawSql 64 | [st| 65 | SELECT SETVAL('district_id_seq', 1, false); 66 | SELECT SETVAL('foo_id_seq', 1, false); 67 | SELECT SETVAL('school_id_seq', 1, false); 68 | SELECT SETVAL('self_ref_id_seq', 1, false); 69 | SELECT SETVAL('state_id_seq', 1, false); 70 | SELECT SETVAL('student_id_seq', 1, false); 71 | SELECT SETVAL('teacher_id_seq', 1, false); 72 | |] 73 | [] 74 | 75 | instance Arbitrary Text where 76 | arbitrary = pack . filter (not . isBadChar) <$> arbitrary 77 | where isBadChar x = x == '\NUL' || x == '\\' -- Make postgres vomit 78 | 79 | share [mkUniquenessChecks sqlSettings { mpsGenerateLenses = True }, mkPersist sqlSettings { mpsGenerateLenses = True }, mkMigrate "testMigrate"] [persistLowerCase| 80 | SelfRef 81 | name Text 82 | selfRefId SelfRefId Maybe 83 | deriving Show Eq Generic 84 | State 85 | name Text 86 | deriving Show Eq Generic 87 | District 88 | name Text 89 | stateId StateId 90 | deriving Show Eq Generic 91 | School 92 | name Text 93 | districtId DistrictId Maybe 94 | deriving Show Eq Generic 95 | Teacher 96 | name Text 97 | schoolId SchoolId 98 | deriving Show Eq Generic 99 | Student 100 | name Text 101 | teacherId TeacherId 102 | deriving Show Eq Generic 103 | Foo 104 | name Text 105 | studentId StudentId Maybe 106 | teacherId TeacherId Maybe 107 | bar Bool 108 | UniqueBar bar -- This is a nonsensical constraint just to test uniqueness violations 109 | deriving Show Eq Generic 110 | Baz 111 | name Text 112 | foo FooId 113 | UniqueFoo foo -- Another nonsensical constraint but one that only has a FK 114 | deriving Show Eq Generic 115 | Quux 116 | name Text 117 | bar Bool 118 | foo FooId 119 | UniqueFooBar foo bar -- A nonsensical constraint that has an FK and plain value 120 | deriving Show Eq Generic 121 | Merp 122 | name Text 123 | bar Bool 124 | baz Bool 125 | whomp Bool Maybe 126 | foo FooId 127 | UniqueFooBarBaz foo bar baz -- A nonsensical constraint that has an FK and two plain values 128 | UniqueWhomp whomp !force -- A second constraint with a nullable field 129 | deriving Show Eq Generic 130 | |] 131 | 132 | instance Arbitrary State where 133 | arbitrary = pure $ State "grault" 134 | instance Arbitrary District where 135 | arbitrary = District "foo" <$> arbitrary 136 | instance Arbitrary School where 137 | arbitrary = School "bar" <$> arbitrary 138 | instance Arbitrary Teacher where 139 | arbitrary = Teacher "baz" <$> arbitrary 140 | instance Arbitrary Student where 141 | arbitrary = Student "qux" <$> arbitrary 142 | instance Arbitrary SelfRef where 143 | arbitrary = SelfRef "self" <$> arbitrary 144 | instance Arbitrary Foo where 145 | arbitrary = Foo "foo" <$> arbitrary <*> arbitrary <*> arbitrary 146 | instance Arbitrary Baz where 147 | arbitrary = Baz "baz" <$> arbitrary 148 | instance Arbitrary Quux where 149 | arbitrary = Quux "quux" <$> arbitrary <*> arbitrary 150 | instance Arbitrary Merp where 151 | arbitrary = Merp "merp" <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary 152 | instance (KnownNat n, Arbitrary a) => Arbitrary (Sized.Vector n a) where 153 | arbitrary = 154 | fromMaybe (error "`vector` should return list of requested length") . Sized.fromList <$> 155 | vector (fromIntegral (natVal (Proxy :: Proxy n))) 156 | 157 | instance SelfRef `PointsAt` Entity SelfRef 158 | instance SelfRef `PointsAt` Maybe (Entity SelfRef) 159 | instance Student `PointsAt` Entity Teacher 160 | instance Teacher `PointsAt` Entity School 161 | instance School `PointsAt` Entity District 162 | instance School `PointsAt` Maybe (Entity District) 163 | instance District `PointsAt` Entity State 164 | instance District `PointsAt` Maybe (Entity State) 165 | instance Foo `PointsAt` Entity Student 166 | instance Foo `PointsAt` Entity Teacher 167 | instance Baz `PointsAt` Entity Foo 168 | instance Quux `PointsAt` Entity Foo 169 | instance Merp `PointsAt` Entity Foo 170 | 171 | _entityKey :: Lens' (Entity a) (Key a) 172 | _entityKey pure' (Entity i e) = (\i' -> Entity i' e) <$> pure' i 173 | 174 | type M = ReaderT SqlBackend (LoggingT IO) 175 | main :: IO () 176 | main = do 177 | runConn $ runMigrationUnsafe testMigrate 178 | hspec $ 179 | describe "poly-graph-persistent" $ do 180 | it "works with plucked lenses" $ do 181 | graph <- 182 | unRawGraph <$> generate arbitrary 183 | :: IO (Line '[Student, Teacher, School]) 184 | let graph' = graph & pluck (Proxy :: Proxy School) . schoolName .~ "Hello" 185 | pure () 186 | -- it "doesn't type check with a dangling (non-`Maybe`) key" $ db $ do 187 | -- graph <- liftIO (generate arbitrary) :: M (HGraph '[ '("Teacher", '[], Teacher) ]) 188 | -- liftIO $ print graph 189 | -- it "doesn't type check with a repeated name" $ db $ do 190 | -- graph <- 191 | -- liftIO (generate arbitrary) 192 | -- :: M (HGraph '[ '("Teacher", '["Teacher"], Teacher), '("Teacher", '[], Student) ]) 193 | -- liftIO $ print graph 194 | it "generates arbitrary entities" $ do 195 | _ <- 196 | generate arbitrary 197 | :: IO (Line '[Entity Student, Entity Teacher, Entity School, Entity District, Entity State]) 198 | pure () 199 | it "works with paired vectors" $ db $ do 200 | void . insert $ School "Bump id" Nothing 201 | arbGraph <- unRawGraph <$> liftIO (generate arbitrary) 202 | entGraph <- 203 | insertGraph arbGraph 204 | :: M 205 | (HGraph 206 | '[ '("T", '["S"], Sized.Vector 3 (Entity Teacher)) 207 | , '("S", '["D"], Sized.Vector 3 (Entity School)) 208 | , '("D", '["St"], Sized.Vector 3 (Entity District)) 209 | , '("St", '[], Entity State) 210 | ] 211 | ) 212 | liftIO $ print entGraph 213 | pure () 214 | it "defaults only missing keys to nothing" $ db $ do 215 | arbGraph <- unRawGraph <$> liftIO (generate arbitrary) 216 | entGraph <- 217 | insertGraph arbGraph 218 | :: M ( 219 | HGraph 220 | '[ '("F", '["S"], Entity Foo) 221 | , '("S", '["T"], Entity Student) 222 | , '("T", '["Sc"], Entity Teacher) 223 | , '("Sc", '["Di"], Entity School) 224 | , '("Di", '["St"], Maybe (Entity District)) 225 | , '("St", '[], Entity State) 226 | ] 227 | ) 228 | liftIO $ (entGraph ^. _head . _entityVal . fooTeacherId) `shouldBe` Nothing 229 | liftIO $ (entGraph ^. _head . _entityVal . fooStudentId) `shouldBe` (Just $ entGraph ^. _tail . _head . _entityKey) 230 | it "defaults `Maybe` keys to `Nothing` during `Arbitrary` creation when they're at the end of the graph" $ do 231 | arbGraph <- generate arbitrary :: IO (Line '[Maybe (Entity SelfRef)]) 232 | (arbGraph ^? _head . _Just . _entityVal . selfRefSelfRefId . _Just) `shouldBe` Nothing 233 | it "defaults `Maybe` keys to `Nothing` during insertion when they're at the end of the graph" $ db $ do 234 | entGraph <- insertGraph . unRawGraph =<< liftIO (generate arbitrary) :: M (Line '[Maybe (Entity SelfRef)]) 235 | liftIO $ (entGraph ^? _head . _Just . _entityVal . selfRefSelfRefId . _Just) `shouldBe` Nothing 236 | it "defaults `Maybe` keys to `Nothing` during `Arbitrary` creation when they're in the middle of the graph" $ do 237 | arbGraph <- 238 | generate arbitrary 239 | :: IO (HGraph '[ '(1, '[], Entity SelfRef), '(2, '[], Maybe (Entity SelfRef)) ]) 240 | (arbGraph ^? _head . _entityVal . selfRefSelfRefId . _Just) `shouldBe` Nothing 241 | it "defaults `Maybe` keys to `Nothing` during insertion when they're in the middle of the graph" $ db $ do 242 | entGraph <- 243 | insertGraph . unRawGraph =<< liftIO (generate arbitrary) 244 | :: M (HGraph '[ '(1, '[], Entity SelfRef), '(2, '[], Maybe (Entity SelfRef)) ]) 245 | liftIO $ (entGraph ^? _head . _entityVal . selfRefSelfRefId . _Just) `shouldBe` Nothing 246 | it "works with unique constraints" $ db $ do 247 | graph <- 248 | liftIO (generate (unique fooBar . unRawGraph =<< arbitrary)) 249 | :: M ( 250 | HGraph 251 | '[ '("Foo1", '[], Foo) 252 | , '("Foo2", '[], Foo) 253 | ] 254 | ) 255 | graph' <- 256 | insertGraph graph 257 | :: M ( 258 | HGraph 259 | '[ '("Foo1", '[], Entity Foo) 260 | , '("Foo2", '[], Entity Foo) 261 | ] 262 | ) 263 | pure () 264 | it "works with unique constraints without using unique" $ db $ do 265 | graph <- 266 | liftIO (generate (ensureGraphUniqueness =<< fmap unRawGraph arbitrary)) 267 | :: M ( 268 | HGraph 269 | '[ '("Foo1", '[], Foo) 270 | , '("Foo2", '[], Foo) 271 | ] 272 | ) 273 | graph' <- 274 | insertGraph graph 275 | :: M ( 276 | HGraph 277 | '[ '("Foo1", '[], Entity Foo) 278 | , '("Foo2", '[], Entity Foo) 279 | ] 280 | ) 281 | pure () 282 | it "works with unique constraints and unique if the latter is used carefully" $ db $ do 283 | graph <- 284 | liftIO (generate (unique fooName =<< ensureGraphUniqueness =<< fmap unRawGraph arbitrary)) 285 | :: M ( 286 | HGraph 287 | '[ '("Foo1", '[], Foo) 288 | , '("Foo2", '[], Foo) 289 | ] 290 | ) 291 | graph' <- 292 | insertGraph graph 293 | :: M ( 294 | HGraph 295 | '[ '("Foo1", '[], Entity Foo) 296 | , '("Foo2", '[], Entity Foo) 297 | ] 298 | ) 299 | pure () 300 | it "ensures internal uniqueness in a single node" $ db $ do 301 | graph <- 302 | liftIO (generate (ensureGraphUniqueness =<< fmap unRawGraph arbitrary)) 303 | :: M ( 304 | HGraph 305 | '[ '("Foo", '[], Sized.Vector 2 Foo) 306 | ] 307 | ) 308 | graph' <- 309 | insertGraph graph 310 | :: M ( 311 | HGraph 312 | '[ '("Foo", '[], Sized.Vector 2 (Entity Foo)) 313 | ] 314 | ) 315 | pure () 316 | it "user can edit graph after it's been uniqued" $ db $ do 317 | graph <- 318 | liftIO (generate (ensureGraphUniqueness =<< fmap unRawGraph arbitrary)) 319 | <&> pluck (Proxy :: Proxy "Foo1") . fooName .~ "foo1" 320 | <&> pluck (Proxy :: Proxy "Foo2") . fooName .~ "foo2" 321 | :: M ( 322 | HGraph 323 | '[ '("Foo1", '[], Foo) 324 | , '("Foo2", '[], Foo) 325 | ] 326 | ) 327 | graph' <- 328 | insertGraph graph 329 | :: M ( 330 | HGraph 331 | '[ '("Foo1", '[], Entity Foo) 332 | , '("Foo2", '[], Entity Foo) 333 | ] 334 | ) 335 | liftIO $ do 336 | graph' ^. pluck (Proxy :: Proxy "Foo1") . _entityVal . fooName `shouldBe` "foo1" 337 | graph' ^. pluck (Proxy :: Proxy "Foo2") . _entityVal . fooName `shouldBe` "foo2" 338 | it "user can un-unique graph after it's been uniqued" $ db $ do 339 | graph <- 340 | liftIO (generate (ensureGraphUniqueness =<< fmap unRawGraph arbitrary)) 341 | <&> pluck (Proxy :: Proxy "Foo1") . fooBar .~ False 342 | <&> pluck (Proxy :: Proxy "Foo2") . fooBar .~ False 343 | :: M ( 344 | HGraph 345 | '[ '("Foo1", '[], Foo) 346 | , '("Foo2", '[], Foo) 347 | ] 348 | ) 349 | let 350 | insertUniquenessViolation = 351 | insertGraph graph 352 | :: M ( 353 | HGraph 354 | '[ '("Foo1", '[], Entity Foo) 355 | , '("Foo2", '[], Entity Foo) 356 | ] 357 | ) 358 | liftIO $ runConn insertUniquenessViolation `shouldThrow` anyException 359 | it "ignores unique constraints consisting solely of FKs" $ db $ do 360 | graph <- 361 | liftIO (generate (ensureGraphUniqueness =<< fmap unRawGraph arbitrary)) 362 | :: M ( 363 | HGraph 364 | '[ '("Baz1", '["Foo"], Baz) 365 | , '("Baz2", '["Foo"], Baz) 366 | , '("Foo", '[], Foo) 367 | ] 368 | ) 369 | let 370 | insertUniquenessViolation = 371 | insertGraph graph 372 | :: M ( 373 | HGraph 374 | '[ '("Baz1", '["Foo"], Entity Baz) 375 | , '("Baz2", '["Foo"], Entity Baz) 376 | , '("Foo", '[], Entity Foo) 377 | ] 378 | ) 379 | liftIO $ runConn insertUniquenessViolation `shouldThrow` anyException 380 | it "ignores the FK component of a unique constraint" $ db $ do 381 | graph <- 382 | liftIO (generate (ensureGraphUniqueness =<< fmap unRawGraph arbitrary)) 383 | :: M ( 384 | HGraph 385 | '[ '("Quux1", '["Foo"], Quux) 386 | , '("Quux2", '["Foo"], Quux) 387 | , '("Foo", '[], Foo) 388 | ] 389 | ) 390 | graph' <- 391 | insertGraph graph 392 | :: M ( 393 | HGraph 394 | '[ '("Quux1", '["Foo"], Entity Quux) 395 | , '("Quux2", '["Foo"], Entity Quux) 396 | , '("Foo", '[], Entity Foo) 397 | ] 398 | ) 399 | pure () 400 | it "ignores the FK component of a unique constraint with multiple plain components" $ db $ do 401 | graph <- 402 | liftIO (generate (ensureGraphUniqueness =<< fmap unRawGraph arbitrary)) 403 | :: M ( 404 | HGraph 405 | '[ '("Merp1", '["Foo"], Merp) 406 | , '("Merp2", '["Foo"], Merp) 407 | , '("Foo", '[], Foo) 408 | ] 409 | ) 410 | graph' <- 411 | insertGraph graph 412 | :: M ( 413 | HGraph 414 | '[ '("Merp1", '["Foo"], Entity Merp) 415 | , '("Merp2", '["Foo"], Entity Merp) 416 | , '("Foo", '[], Entity Foo) 417 | ] 418 | ) 419 | pure () 420 | it "works with Maybe key to plain" $ db $ do 421 | graph <- 422 | unRawGraph <$> liftIO (generate arbitrary) 423 | :: M ( 424 | HGraph 425 | '[ '("Plain1", '["Plain2"], SelfRef) 426 | , '("Plain2", '[], SelfRef) 427 | ] 428 | ) 429 | graph' <- 430 | insertGraph graph 431 | :: M ( 432 | HGraph 433 | '[ '("Plain1", '["Plain2"], Entity SelfRef) 434 | , '("Plain2", '[], Entity SelfRef) 435 | ] 436 | ) 437 | liftIO $ 438 | (graph' ^. pluck (Proxy :: Proxy "Plain1") . _entityVal . selfRefSelfRefId) `shouldBe` 439 | (Just $ graph' ^. pluck (Proxy :: Proxy "Plain2") . _entityKey) 440 | it "works with a variety of `Maybe`, `Always`, `Never` combinations" $ db $ do 441 | graph <- 442 | unRawGraph <$> liftIO (generate arbitrary) 443 | :: M ( 444 | HGraph 445 | '[ '("Plain1", '["Maybe1", "Always1", "Plain2"], SelfRef) 446 | , '("Maybe1", '["Always1", "Plain2", "Maybe2"], Maybe SelfRef) 447 | , '("Always1", '["Plain2", "Maybe2", "Always2"], SelfRef) 448 | , '("Plain2", '[], SelfRef) 449 | , '("Maybe2", '[], Maybe SelfRef) 450 | , '("Always2", '[], SelfRef) 451 | ] 452 | ) 453 | _ <- 454 | insertGraph graph 455 | :: M ( 456 | HGraph 457 | '[ '("Plain1", '["Maybe1", "Always1", "Plain2"], Entity SelfRef) 458 | , '("Maybe1", '["Always1", "Plain2", "Maybe2"], Maybe (Entity SelfRef)) 459 | , '("Always1", '["Plain2", "Maybe2", "Always2"], Entity SelfRef) 460 | , '("Plain2", '[], Entity SelfRef) 461 | , '("Maybe2", '[], Maybe (Entity SelfRef)) 462 | , '("Always2", '[], Entity SelfRef) 463 | ] 464 | ) 465 | pure () 466 | 467 | it "Manual creation and insertion should produce the same results as automatic creation and insertion" $ db $ do 468 | stateId1 <- insert $ State "CA" 469 | void . insert $ District "bump id to prove we're doing something mildly interesting" stateId1 470 | 471 | stateB <- liftIO $ generate arbitrary 472 | stateId2 <- insert stateB 473 | diB <- fmap (set districtStateId stateId2) . liftIO $ generate arbitrary 474 | diId <- insert diB 475 | scB <- fmap (set schoolDistrictId (Just diId)) . liftIO $ generate arbitrary 476 | scId <- insert scB 477 | teB <- fmap (set teacherSchoolId scId) . liftIO $ generate arbitrary 478 | teId <- insert teB 479 | stB <- fmap (set studentTeacherId teId) . liftIO $ generate arbitrary 480 | stId <- insert stB 481 | 482 | resetSequences 483 | transactionUndo 484 | stateId3 <- insert $ State "CA" 485 | void . insert $ District "bump id to prove we're doing something mildly interesting" stateId3 486 | 487 | graph <- 488 | unRawGraph <$> liftIO (generate arbitrary) 489 | (st :< te :< sc :< di :< state :< Nil) <- 490 | insertGraph graph 491 | :: M ( 492 | Line 493 | '[ Entity Student 494 | , Entity Teacher 495 | , Entity School 496 | , Entity District 497 | , Entity State 498 | ] 499 | ) 500 | let manualTree = (Entity stId stB, Entity teId teB, Entity scId scB, Entity diId diB, Entity stateId2 stateB) 501 | let autoTree = (st, te, sc, di, state) 502 | liftIO $ autoTree `shouldBe` manualTree 503 | -------------------------------------------------------------------------------- /poly-graph-persistent/test/Spec2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE QuasiQuotes #-} 12 | {-# LANGUAGE RecordWildCards #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | {-# LANGUAGE ViewPatterns #-} 19 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 20 | {-# OPTIONS_GHC -fno-warn-unused-matches #-} 21 | {-# OPTIONS_GHC -fno-warn-orphans #-} 22 | 23 | import Test.Hspec 24 | 25 | import Control.Lens hiding ((:<), _head, _tail) 26 | import Control.Monad (void) 27 | import Control.Monad.IO.Class (MonadIO) 28 | import Control.Monad.Logger (LoggingT(..), runStderrLoggingT) 29 | import Control.Monad.IO.Class (liftIO) 30 | import Control.Monad.Trans.Reader (ReaderT) 31 | import Control.Monad.Trans.Resource (ResourceT, runResourceT, MonadBaseControl) 32 | import qualified Data.ByteString.Char8 as B8 33 | import Data.Proxy (Proxy(..)) 34 | import Data.Text (Text, pack) 35 | import Data.Time.Calendar 36 | import Data.Time.Clock 37 | import Database.Persist 38 | import Database.Persist.Postgresql 39 | import Database.Persist.Sql 40 | import Database.Persist.TH 41 | import GHC.Generics (Generic) 42 | import System.Log.FastLogger (fromLogStr) 43 | import Test.QuickCheck.Arbitrary (Arbitrary(..), arbitrarySizedNatural) 44 | import Test.QuickCheck.Gen (generate) 45 | import Text.Shakespeare.Text (st) 46 | 47 | import Data.Graph.HGraph 48 | import Data.Graph.HGraph.Instances () 49 | import Data.Graph.HGraph.Persistent 50 | import Data.Graph.HGraph.Persistent.Instances () 51 | import Data.Graph.HGraph.TH 52 | 53 | connString :: ConnectionString 54 | connString = "host=localhost port=5432 user=test dbname=poly-graph password=test" 55 | 56 | runConn :: (MonadIO m, MonadBaseControl IO m) => SqlPersistT (LoggingT m) t -> m t 57 | runConn = runStderrLoggingT . withPostgresqlConn connString . runSqlConn 58 | 59 | db :: SqlPersistT (LoggingT IO) () -> IO () 60 | db actions = runConn $ actions >> resetSequences >> transactionUndo 61 | 62 | resetSequences :: (MonadIO m) => SqlPersistT (LoggingT m) [Single Int] 63 | resetSequences = 64 | rawSql 65 | [st| 66 | SELECT SETVAL('district_id_seq', 1, false); 67 | SELECT SETVAL('school_id_seq', 1, false); 68 | SELECT SETVAL('student_id_seq', 1, false); 69 | SELECT SETVAL('teacher_id_seq', 1, false); 70 | SELECT SETVAL('multi_pointer_id_seq', 1, false); 71 | |] 72 | [] 73 | 74 | instance Arbitrary Text where 75 | arbitrary = pack . filter (not . isBadChar) <$> arbitrary 76 | where isBadChar x = x == '\NUL' || x == '\\' -- These make postgres vomit 77 | 78 | _entityKey :: Lens' (Entity a) (Key a) 79 | _entityKey pure' (Entity i e) = (\i' -> Entity i' e) <$> pure' i 80 | 81 | share [mkPersist sqlSettings { mpsGenerateLenses = True }, mkMigrate "testMigrate"] [persistLowerCase| 82 | District 83 | name Text 84 | createdAt UTCTime 85 | deriving Show Eq Generic 86 | School 87 | name Text 88 | createdAt UTCTime 89 | districtId DistrictId Maybe 90 | deriving Show Eq Generic 91 | Teacher 92 | name Text 93 | createdAt UTCTime 94 | schoolId SchoolId 95 | deriving Show Eq Generic 96 | Student 97 | name Text 98 | createdAt UTCTime 99 | teacherId TeacherId 100 | deriving Show Eq Generic 101 | MultiPointer 102 | name 103 | teacherId TeacherId 104 | schoolId SchoolId 105 | deriving Show Eq Generic 106 | |] 107 | instance Arbitrary District where 108 | arbitrary = District <$> arbitrary <*> arbitrary 109 | instance Arbitrary School where 110 | arbitrary = School <$> arbitrary <*> arbitrary <*> arbitrary 111 | instance Arbitrary Teacher where 112 | arbitrary = Teacher <$> arbitrary <*> arbitrary <*> arbitrary 113 | instance Arbitrary Student where 114 | arbitrary = Student <$> arbitrary <*> arbitrary <*> arbitrary 115 | instance Arbitrary MultiPointer where 116 | arbitrary = MultiPointer <$> arbitrary <*> arbitrary 117 | instance Arbitrary Day where 118 | arbitrary = ModifiedJulianDay <$> arbitrarySizedNatural 119 | instance Arbitrary DiffTime where 120 | arbitrary = secondsToDiffTime <$> arbitrarySizedNatural 121 | instance Arbitrary UTCTime where 122 | arbitrary = UTCTime <$> arbitrary <*> arbitrary 123 | 124 | instance Student `PointsAt` Entity Teacher 125 | instance Teacher `PointsAt` Entity School 126 | instance School `PointsAt` Entity District 127 | instance School `PointsAt` Maybe (Entity District) 128 | instance MultiPointer `PointsAt` Entity Teacher 129 | instance MultiPointer `PointsAt` Entity School 130 | 131 | type M = ReaderT SqlBackend (LoggingT IO) 132 | 133 | studentIsInDistrict :: Entity Student -> Entity Teacher -> Entity School -> Entity District -> Bool 134 | studentIsInDistrict 135 | (Entity _ Student{ .. }) 136 | (Entity teacherId Teacher{ .. }) 137 | (Entity schoolId School{ _schoolDistrictId }) 138 | (Entity districtId _) = 139 | _studentTeacherId == teacherId && 140 | _teacherSchoolId == schoolId && 141 | _schoolDistrictId == Just districtId && 142 | _studentName /= _teacherName 143 | 144 | arbitrary' :: (Arbitrary a) => M a 145 | arbitrary' = liftIO (generate arbitrary) 146 | 147 | main :: IO () 148 | main = do 149 | now <- getCurrentTime 150 | runConn $ runMigrationUnsafe testMigrate 151 | hspec $ 152 | describe "" $ do 153 | it "we can test our function the old-fashioned way" $ db $ do 154 | district@(Entity districtId _) <- insertEntity $ District "districtName" now 155 | school1@(Entity schoolId1 _) <- insertEntity $ School "school1" now (Just districtId) 156 | school2@(Entity schoolId2 _) <- insertEntity $ School "school2" now Nothing 157 | teacher1@(Entity teacherId1 _) <- insertEntity $ Teacher "teacher1" now schoolId1 158 | teacher2@(Entity teacherId2 _) <- insertEntity $ Teacher "teacher2" now schoolId2 159 | student@(Entity studentId _) <- insertEntity $ Student "student1" now teacherId1 160 | liftIO $ studentIsInDistrict student teacher1 school1 district `shouldBe` True 161 | it "but this is tedious and, consequently, error prone" $ db $ do 162 | district@(Entity districtId _) <- insertEntity $ District "districtName" now 163 | school1@(Entity schoolId1 _) <- insertEntity $ School "school1" now (Just districtId) 164 | school2@(Entity schoolId2 _) <- insertEntity $ School "school2" now Nothing 165 | teacher1@(Entity teacherId1 _) <- insertEntity $ Teacher "teacher1" now schoolId2 166 | teacher2@(Entity teacherId2 _) <- insertEntity $ Teacher "teacher2" now schoolId2 167 | student@(Entity studentId _) <- insertEntity $ Student "student1" now teacherId1 168 | liftIO $ studentIsInDistrict student teacher1 school1 district `shouldBe` False 169 | it "furthermore, it's not obvious which properties of the item we care about" $ db $ do 170 | district@(Entity districtId _) <- insertEntity $ District "districtName" now 171 | school1@(Entity schoolId1 _) <- insertEntity $ School "school1" now (Just districtId) 172 | school2@(Entity schoolId2 _) <- insertEntity $ School "school2" now Nothing 173 | teacher1@(Entity teacherId1 _) <- insertEntity $ Teacher "1" now schoolId1 174 | teacher2@(Entity teacherId2 _) <- insertEntity $ Teacher "teacher2" now schoolId2 175 | student@(Entity studentId _) <- insertEntity $ Student "1" now teacherId1 176 | liftIO $ studentIsInDistrict student teacher1 school1 district `shouldBe` False 177 | it "using 'Arbitrary` can help, especially with that last problem. But now we have to set each FK by hand" $ db $ do 178 | district@(Entity districtId _) <- insertEntity =<< arbitrary' 179 | school1@(Entity schoolId1 _) <- insertEntity . set schoolDistrictId (Just districtId) =<< arbitrary' 180 | school2@(Entity schoolId2 _) <- insertEntity . set schoolDistrictId (Just districtId) =<< arbitrary' 181 | teacher1@(Entity teacherId1 _) <- insertEntity . set teacherSchoolId schoolId1 . set teacherName "Foo" =<< arbitrary' 182 | teacher2@(Entity teacherId2 _) <- insertEntity . set teacherSchoolId schoolId2 =<< arbitrary' 183 | student@(Entity studentId _) <- insertEntity . set studentTeacherId teacherId1 . set studentName "Bar" =<< arbitrary' 184 | liftIO $ studentIsInDistrict student teacher1 school1 district `shouldBe` True 185 | it "enter HGraph" $ db $ do 186 | arbGraph <- unRawGraph <$> arbitrary' 187 | (st :< te :< sc :< di :< Nil) <- 188 | insertGraph arbGraph :: M (Line '[Entity Student, Entity Teacher, Entity School, Entity District]) 189 | liftIO $ studentIsInDistrict st te sc di `shouldBe` True 190 | it "And we can set nested properties we care about" $ db $ do 191 | arbGraph <- unRawGraph <$> arbitrary' 192 | let arbGraph' = 193 | arbGraph 194 | & pluck (Proxy :: Proxy (Entity Teacher)) . teacherName .~ "Foo" 195 | & pluck (Proxy :: Proxy (Entity Student)) . studentName .~ "Bar" 196 | (st :< te :< sc :< di :< Nil) <- 197 | insertGraph arbGraph' :: M (Line '[Entity Student, Entity Teacher, Entity School, Entity District]) 198 | liftIO $ studentIsInDistrict st te sc di `shouldBe` True 199 | it "we can also omit some entities and get sensible defaulting" $ db $ do 200 | arbGraph <- unRawGraph <$> arbitrary' 201 | (st :< te :< sc :< Nil) <- 202 | insertGraph arbGraph :: M (Line '[Entity Student, Entity Teacher, Entity School]) 203 | liftIO $ sc ^. _entityVal . schoolDistrictId `shouldBe` Nothing 204 | it "but if we omit entities that are required, we get a type error" $ db $ do 205 | -- arbGraph <- unRawGraph <$> arbitrary' 206 | -- (st :< te :< Nil) <- 207 | -- insertGraph arbGraph :: M (Line '[Entity Student, Entity Teacher]) 208 | pure () 209 | it "finally, we can do much more complicated directed graphs, if we need to" $ db $ do 210 | arbGraph <- arbitrary' 211 | :: 212 | M ( 213 | HGraph 214 | '[ '("Student1", '["Teacher1"], Entity Student) 215 | , '("Student2", '["Teacher2"], Entity Student) 216 | , '("Multi", '["Teacher1", "School"], Entity MultiPointer) 217 | , '("Teacher1", '["School"], Entity Teacher) 218 | , '("Teacher2", '["School"], Entity Teacher) 219 | , '("School", '["District"], Entity School) 220 | , '("District", '[], Maybe (Entity District)) 221 | ] 222 | ) 223 | pure () 224 | -------------------------------------------------------------------------------- /poly-graph/LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Eric Easley 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /poly-graph/README.md: -------------------------------------------------------------------------------- 1 | # poly-graph 2 | 3 | This is a library for polymorphic (i.e. nodes do not all have to be of the same type) directed acyclic graphs. 4 | 5 | To get a sense of how to construct such graphs, look in the tests. 6 | -------------------------------------------------------------------------------- /poly-graph/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /poly-graph/poly-graph.cabal: -------------------------------------------------------------------------------- 1 | name: poly-graph 2 | version: 0.1.0.0 3 | synopsis: Polymorphic directed graphs 4 | description: Please see README.md 5 | homepage: http://github.com/pseudonom/poly-graph 6 | license: MIT 7 | license-file: LICENSE 8 | author: Eric Easley 9 | maintainer: eric101111@gmail.com 10 | copyright: 2016 Eric Easley 11 | category: Data Structures 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Data.Graph.HGraph 19 | , Data.Graph.HGraph.Instances 20 | , Data.Graph.HGraph.Internal 21 | , Data.Graph.HGraph.TH 22 | build-depends: base >= 4.7 && < 5 23 | , tagged 24 | , generics-eot 25 | , QuickCheck 26 | , profunctors 27 | , template-haskell 28 | , vector-sized 29 | default-language: Haskell2010 30 | 31 | test-suite poly-graph-test 32 | type: exitcode-stdio-1.0 33 | hs-source-dirs: test 34 | main-is: Spec.hs 35 | build-depends: base 36 | , poly-graph 37 | , hspec 38 | , tagged 39 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 40 | default-language: Haskell2010 41 | 42 | source-repository head 43 | type: git 44 | location: https://github.com/pseudonom/poly-graph 45 | -------------------------------------------------------------------------------- /poly-graph/src/Data/Graph/HGraph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PatternSynonyms #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE Rank2Types #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | -- Pattern synonyms and exhaustivity checking don't work well together 16 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 17 | {-# OPTIONS_GHC -fno-warn-orphans #-} 18 | 19 | module Data.Graph.HGraph 20 | ( module Data.Graph.HGraph 21 | , X.HGraph(Nil) 22 | , X._head 23 | , X._tail 24 | , X.Node(..) 25 | , X.retag 26 | ) where 27 | 28 | import Data.Type.Bool 29 | import Data.Type.Equality 30 | import qualified Data.Vector.Sized as Sized 31 | import Data.Proxy 32 | import Generics.Eot (Void, fromEot, toEot, Eot, HasEot) 33 | import Test.QuickCheck.Arbitrary 34 | 35 | import Data.Graph.HGraph.Internal as X 36 | 37 | -- | This class specifies how to link two types to reflect their type level linkage in an @HGraph@. 38 | infixr 5 `PointsAt` 39 | class a `PointsAt` b where 40 | infixr 5 `pointsAt` 41 | pointsAt :: a -> b -> a 42 | default pointsAt :: (HasEot a, Eot a `GPointsAt` b) => a -> b -> a 43 | pointsAt a b = fromEot $ toEot a `gPointsAt` b 44 | 45 | -- | This class provides the @Generic@ default implementation of @PointsAt@. 46 | -- We provide the basic recursive structure here to save the end user some boilerplate. 47 | class a `GPointsAt` b where 48 | infixr 5 `gPointsAt` 49 | gPointsAt :: a -> b -> a 50 | instance 51 | (a `GPointsAt` c, b `GPointsAt` c) => 52 | Either a b `GPointsAt` c where 53 | Left a `gPointsAt` b = Left $ a `gPointsAt` b 54 | Right a `gPointsAt` b = Right $ a `gPointsAt` b 55 | instance 56 | (a `FieldPointsAt` c, b `GPointsAt` c) => 57 | (a, b) `GPointsAt` c where 58 | (a, b) `gPointsAt` c = (a `fieldPointsAt` c, b `gPointsAt` c) 59 | instance GPointsAt () a where 60 | gPointsAt _ _ = () 61 | instance GPointsAt Void a where 62 | gPointsAt _ _ = error "impossible" 63 | 64 | -- | This defines the actual interesting behavior happens in our @Generic@ implementation of @PointsAt@. 65 | class FieldPointsAt a b where 66 | fieldPointsAt :: a -> b -> a 67 | 68 | -- | "Read-only" pattern allows convenient destructuring while encouraging preservation 69 | -- linkage invariant 70 | infixr 5 :< 71 | -- pattern (:<) :: Member i b ~ 'UniqueName => a -> HGraph b -> HGraph ('(i, is, a) ': b) 72 | pattern a :< b <- Node a `Cons` b 73 | 74 | -- | We don't strictly need @pointedFrom@ but it makes our errors much more helpful. 75 | class Nullify (pointedFrom :: *) (pointedTo :: *) where 76 | nullify :: Proxy pointedFrom -> pointedTo -> pointedTo 77 | 78 | -- | Handles early escape from @NullifyRecurse@. 79 | class EscapeNullify (pointedFrom :: *) (match :: Bool) (a :: *) where 80 | escapeNullify :: Proxy pointedFrom -> Proxy match -> a -> a 81 | -- | If we previously set this @Nullable@, leave it alone and terminate recursion. 82 | instance EscapeNullify pointedFrom 'True a where 83 | escapeNullify Proxy Proxy = id 84 | -- | If we didn't previously set this @Nullable@, @nullify@ is still a possibility. 85 | -- Continue the recursion to see if we do actually get to @nullify@. 86 | instance 87 | (Nullify pointedFrom a) => 88 | EscapeNullify pointedFrom 'False a where 89 | escapeNullify p Proxy a = nullify p a 90 | 91 | type family BaseMember (a :: *) (as :: [*]) :: Bool where 92 | BaseMember b '[] = 'False 93 | BaseMember b (a ': as) = If (Base b == Base a) 'True (BaseMember b as) 94 | 95 | -- | Uses the list of completed linkages to determine if this key should be nullable. 96 | -- For example, if we've already done @A `PointsAt` Entity B@, we shouldn't wipe @A@'s key to @B@. 97 | class NullifyRecurse (pointedFrom :: *) (completedLinkages :: [*]) (a :: *) where 98 | nullifyRecurse :: Proxy pointedFrom -> Proxy completedLinkages -> a -> a 99 | -- | There's at least one more linkage left to examine. 100 | -- Test if the candidate @Nullable@ equals the current link and call the corresponding @EscapeNullify@. 101 | instance 102 | (BaseMember a completedLinkages ~ match, EscapeNullify pointedFrom match a) => 103 | NullifyRecurse (pointedFrom :: *) (completedLinkages :: [*]) (a :: *) where 104 | nullifyRecurse _ Proxy = escapeNullify (Proxy :: Proxy pointedFrom) (Proxy :: Proxy match) 105 | 106 | -- | This provides the basic structure of @eot@ recursion so end users don't have to worry about it. 107 | -- Users only have to define the @Nullify@ instances. 108 | class GNullify (original :: *) (typesLinked :: [*]) (a :: *) where 109 | gNullify :: Proxy original -> Proxy typesLinked -> a -> a 110 | instance (GNullify original typesLinked a, GNullify original typesLinked b) => GNullify original typesLinked (Either a b) where 111 | gNullify og tl (Left a) = Left $ gNullify og tl a 112 | gNullify og tl (Right b) = Right $ gNullify og tl b 113 | instance (NullifyRecurse original typesLinked a, GNullify original typesLinked b) => GNullify original typesLinked (a, b) where 114 | gNullify og tl (a, b) = (nullifyRecurse og tl a, gNullify og tl b) 115 | instance GNullify og ps () where 116 | gNullify Proxy Proxy () = () 117 | instance GNullify og ps Void where 118 | gNullify = error "impossible" 119 | 120 | -- | You'd think this is a totally pointless type class and you could just lift @pointsAtR@ to a top-level function. 121 | -- For some reason you can't. GHC complains about ambiguous type variables if you do. 122 | class PointsAtR (i :: k) (is :: [k]) a (b :: [(k, [k], *)]) where 123 | pointsAtR :: Node i is a -> HGraph b -> Node i is a 124 | instance (PointsAtRInternal is '[] i is a graph) => PointsAtR i is a graph where 125 | pointsAtR = pointsAtRInternal (Proxy :: Proxy is) (Proxy :: Proxy '[]) 126 | 127 | class PointsAtRInternal 128 | (originalLinks :: [k]) 129 | (typesLinked :: [*]) 130 | (i :: k) 131 | (remainingLinks :: [k]) 132 | (a :: *) 133 | (graph :: [(k, [k], *)]) 134 | where 135 | pointsAtRInternal :: Proxy originalLinks -> Proxy typesLinked -> Node i remainingLinks a -> HGraph graph -> Node i remainingLinks a 136 | 137 | 138 | -- | We split out the type family because we can't create the optic for some types. For example, @Lens' (Key a) a@. 139 | type family Base (a :: *) :: * where 140 | Base (f a) = Base a 141 | Base a = a 142 | 143 | class ToBase a where 144 | base :: Traversal' a (Base a) 145 | 146 | instance (ToBase a) => ToBase (Sized.Vector n a) where 147 | base afb s = traverse (base afb) s 148 | 149 | instance (ToBase a) => ToBase (Maybe a) where 150 | base = _Just . base 151 | 152 | _Node :: Lens' (Node i is a) a 153 | _Node pure' (Node a) = Node <$> pure' a 154 | instance (ToBase a) => ToBase (Node i is a) where 155 | base = _Node . base 156 | 157 | instance {-# OVERLAPPABLE #-} (Base a ~ a) => ToBase a where 158 | base = id 159 | 160 | -- | Base case. Doesn't point at anything. 161 | instance (ToBase a, Base a ~ b, HasEot b, GNullify a typesLinked (Eot b)) => 162 | PointsAtRInternal originalLinks typesLinked i '[] a graph where 163 | pointsAtRInternal Proxy Proxy n _ = 164 | n & _Node . base %~ fromEot . gNullify (Proxy :: Proxy a) (Proxy :: Proxy typesLinked) . toEot 165 | 166 | -- | Points at wrong thing 167 | instance 168 | (PointsAtRInternal originalLinks typesLinked i (link ': remainingLinks) a graph) => 169 | PointsAtRInternal originalLinks typesLinked i (link ': remainingLinks) a ('(j, js, b) ': graph) where 170 | pointsAtRInternal ol tl a (Cons _ c) = pointsAtRInternal ol tl a c 171 | 172 | type family Snoc (as :: [k]) (a :: k) :: [k] where 173 | Snoc '[] a = '[a] 174 | Snoc (a ': as) b = a ': (as `Snoc` b) 175 | 176 | -- | Adjacent 177 | instance {-# OVERLAPPING #-} 178 | ( Node i (link ': remainingLinks) a `PointsAt` Node link js b 179 | , PointsAtRInternal originalLinks (typesLinked `Snoc` b) i remainingLinks a c 180 | ) => 181 | PointsAtRInternal originalLinks typesLinked i (link ': remainingLinks) a ('(link, js, b) ': c) where 182 | pointsAtRInternal ol Proxy a (Cons b c) = retag $ pointsAtRInternal ol (Proxy :: Proxy (typesLinked `Snoc` b)) a' c 183 | where 184 | a' :: Node i remainingLinks a 185 | a' = retag $ a `pointsAt` b 186 | 187 | infixr 5 ~> 188 | (~>) :: 189 | ((i `Member` b) ~ 'UniqueName, PointsAtRInternal is '[] i is a b) => 190 | a -> HGraph b -> HGraph ('(i, is, a) ': b) 191 | a ~> b = (Node a `pointsAtR` b) `Cons` b 192 | 193 | -- @RawGraph@ is required because, without it, we have to provide no-op @PointsAt@ instances for 194 | -- building the @Arbitrary@ graph we hand to @insertGraph@. i.e. 195 | -- @instance (a `PointsAt` Entity b) => a `PointsAt` b where a `pointsAt` _ = a@ 196 | -- But then any graphs missing an instance match this instance and fail via a context reduction stack overflow 197 | -- which is pretty ugly. 198 | data RawGraph a = RawGraph { unRawGraph :: HGraph a } 199 | 200 | instance Arbitrary (RawGraph '[]) where 201 | arbitrary = pure $ RawGraph Nil 202 | instance 203 | ((i `Member` b) ~ 'UniqueName, Arbitrary (Node i is a), Arbitrary (RawGraph b)) => 204 | Arbitrary (RawGraph ('(i, is, a) ': b)) where 205 | arbitrary = RawGraph <$> (Cons <$> arbitrary <*> (unRawGraph <$> arbitrary)) 206 | 207 | instance Arbitrary (HGraph '[]) where 208 | arbitrary = pure Nil 209 | instance 210 | ( (i `Member` b) ~ 'UniqueName 211 | , PointsAtRInternal is '[] i is a b 212 | , Arbitrary (Node i is a), Arbitrary (HGraph b) 213 | ) => 214 | Arbitrary (HGraph ('(i, is, a) ': b)) where 215 | arbitrary = do 216 | b <- arbitrary 217 | a <- arbitrary 218 | pure $ (a `pointsAtR` b) `Cons` b 219 | 220 | 221 | class Pluck name a b | name a -> b where 222 | pluck :: Proxy name -> Lens' (HGraph a) b 223 | instance {-# OVERLAPPING #-} Pluck name ('(name, is, b) ': c) b where 224 | pluck Proxy = _head 225 | instance (Pluck name d b) => Pluck name ('(otherName, is, c) ': d) b where 226 | pluck p = _tail . pluck p 227 | 228 | 229 | allOfType :: (GetAllOfType a b, SetAllOfType a b) => Traversal' (HGraph a) b 230 | allOfType = 231 | traversal getAllOfType setAllOfType 232 | where 233 | traversal :: (s -> [a]) -> (s -> [b] -> t) -> Traversal s t a b 234 | traversal get set afb s = set s <$> traverse afb (get s) 235 | 236 | class GetAllOfType a ty where 237 | getAllOfType :: HGraph a -> [ty] 238 | instance GetAllOfType '[] ty where 239 | getAllOfType Nil = [] 240 | instance {-# OVERLAPPING #-} (GetAllOfType c ty) => GetAllOfType ('(name, is, ty) ': c) ty where 241 | getAllOfType (a :< rest) = a : getAllOfType rest 242 | instance (GetAllOfType c ty) => GetAllOfType ('(name, is, ty') ': c) ty where 243 | getAllOfType (_ :< rest) = getAllOfType rest 244 | 245 | class SetAllOfType a ty where 246 | setAllOfType :: HGraph a -> [ty] -> HGraph a 247 | instance SetAllOfType '[] ty where 248 | setAllOfType Nil [] = Nil 249 | instance {-# OVERLAPPING #-} (SetAllOfType c ty) => SetAllOfType ('(name, is, ty) ': c) ty where 250 | setAllOfType (_ :< rest) (a' : rest') = Node a' `Cons` setAllOfType rest rest' 251 | instance (SetAllOfType c ty) => SetAllOfType ('(name, is, ty') ': c) ty where 252 | setAllOfType (a `Cons` rest) rest' = a `Cons` setAllOfType rest rest' 253 | 254 | 255 | type Line as = HGraph (Line' as) 256 | 257 | type family Line' (as :: [*]) :: [(*, [*], *)] where 258 | Line' '[k] = '[Ty k '[]] 259 | Line' (k ': l ': m) = Ty k '[l] ': Line' (l ': m) 260 | 261 | type Ty a b = '(a, b, a) 262 | 263 | infixr 5 :++ 264 | type family (a :: [k]) :++ (b :: [k]) :: [k] where 265 | '[] :++ ys = ys 266 | (x ': xs) :++ ys = x ': (xs :++ ys) 267 | type family Concat (as :: [[k]]) :: [k] where 268 | Concat '[] = '[] 269 | Concat (x ': xs) = x :++ Concat xs 270 | 271 | composeAll :: [a -> a] -> a -> a 272 | composeAll = foldl (.) id 273 | 274 | graphFragments :: Proxy (ass :: [[(k, [k], *)]]) -> [HGraph bs -> HGraph bs] -> (Proxy (Concat ass), HGraph bs -> HGraph bs) 275 | graphFragments Proxy fs = (Proxy, composeAll fs) 276 | -------------------------------------------------------------------------------- /poly-graph/src/Data/Graph/HGraph/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE PatternSynonyms #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE TypeSynonymInstances #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | -- Pattern synonyms and exhaustivity checking don't work well together 14 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 15 | {-# OPTIONS_GHC -fno-warn-orphans #-} 16 | 17 | module Data.Graph.HGraph.Instances where 18 | 19 | import Data.Proxy 20 | import qualified Data.Vector.Sized as Sized 21 | import GHC.TypeLits 22 | 23 | import Data.Graph.HGraph 24 | 25 | -- | The underlying HGraph uses @Node@s. 26 | -- This instance unwraps @Node@s and tries to find a way to point one node body at the other. 27 | instance {-# OVERLAPPING #-} (a `DispatchOnTyCons` b) => Node i (j ': is) a `PointsAt` Node j js b where 28 | Node a `pointsAt` Node b = Node $ a `pointsAtDispatcher` b 29 | 30 | -- | Using overlapping instances in @PointsAtInternal@ quickly turns into a hot mess. 31 | -- Instead, we use a trick in which an outer type class with @Proxy@s controls 32 | -- which instance of an inner type class applies. 33 | -- In particular, @NoTyCon@, which witnesses that the type variable @a@ 34 | -- is not of the form @f b@ is very useful. 35 | class DispatchOnTyCons a b where 36 | pointsAtDispatcher :: a -> b -> a 37 | -- | The left side is of the form @f a@. 38 | instance 39 | {-# OVERLAPPING #-} 40 | (lf ~ HandleLeft f 41 | , PointsAtInternal lf (f a) b 42 | ) => 43 | DispatchOnTyCons (f a) b where 44 | pointsAtDispatcher = pointsAtInternal (Proxy :: Proxy lf) 45 | -- | The left hand side isn't higher kinded. 46 | instance 47 | (PointsAtInternal "NoTyCon" a b) => 48 | DispatchOnTyCons a b where 49 | pointsAtDispatcher = pointsAtInternal (Proxy :: Proxy "NoTyCon") 50 | 51 | -- | Collapsing some of the functors on the left hand side of @PointsAt@ into @SomeFunctor@ 52 | -- saves us from defining some duplicative instances. 53 | type family HandleLeft (f :: * -> *) :: Symbol 54 | type instance HandleLeft Maybe = "SomeFunctor" 55 | type instance HandleLeft [] = "SomeFunctor" 56 | type instance HandleLeft (Sized.Vector n) = "SizedVector" 57 | 58 | -- | Helpers that automatically provide certain additional @PointsAt@ instances 59 | -- in terms of a few base @instances@. 60 | class PointsAtInternal (leftTyCon :: Symbol) a b where 61 | pointsAtInternal :: Proxy leftTyCon -> a -> b -> a 62 | 63 | instance 64 | (a `PointsAt` Maybe b) => 65 | PointsAtInternal "NoTyCon" a (Maybe b) where 66 | pointsAtInternal Proxy a b = a `pointsAt` b 67 | 68 | -- | Unless otherwise specified, functors @pointAt@ via @fmap@. 69 | instance 70 | (Functor f, a `DispatchOnTyCons` b) => 71 | PointsAtInternal "SomeFunctor" (f a) b where 72 | pointsAtInternal Proxy fa b = (`pointsAtDispatcher` b) <$> fa 73 | 74 | instance (PointsAtInternal "NoTyCon" a b) => PointsAtInternal "SizedVector" (Sized.Vector n a) (Sized.Vector n b) where 75 | pointsAtInternal Proxy = Sized.zipWith pointsAtDispatcher 76 | instance {-# OVERLAPPABLE #-} (PointsAtInternal "NoTyCon" a b) => PointsAtInternal "SizedVector" (Sized.Vector n a) b where 77 | pointsAtInternal Proxy f t = (`pointsAtDispatcher` t) <$> f 78 | -------------------------------------------------------------------------------- /poly-graph/src/Data/Graph/HGraph/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE Rank2Types #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | 13 | -- | You should try to avoid using this module. 14 | -- It has the raw @PointsTo@ and consequently allows you to construct @:~>:@ 15 | -- which aren't actually linked. 16 | module Data.Graph.HGraph.Internal where 17 | 18 | import Data.Functor.Identity 19 | import Data.Profunctor 20 | import Data.Profunctor.Unsafe ((#.)) 21 | import Data.Monoid ((<>)) 22 | import GHC.Generics (Generic) 23 | import Test.QuickCheck.Arbitrary (Arbitrary(..)) 24 | 25 | data Node (i :: k) (is :: [k]) a = Node { unNode :: a } deriving (Eq, Show, Functor, Generic) 26 | 27 | retag :: Node i is a -> Node j js a 28 | retag (Node a) = Node a 29 | 30 | 31 | data IsDuplicateName a 32 | = UniqueName 33 | | DuplicateName a 34 | 35 | type family Member (a :: k) (as :: [(k, [k], *)]) :: IsDuplicateName k where 36 | Member a '[] = 'UniqueName 37 | Member name ('(name, js, b) ': as) = 'DuplicateName name 38 | Member a (b ': as) = Member a as 39 | 40 | infixr 5 `Cons` 41 | data HGraph y where 42 | Cons :: ((i `Member` b) ~ 'UniqueName) => Node i is a -> HGraph b -> HGraph ('(i, is, a) ': b) 43 | Nil :: HGraph '[] 44 | 45 | -- | Please don't use these lenses to edit the FK fields 46 | _head :: Lens' (HGraph ('(i, is, a) ': b)) a 47 | _head pure' (Node a `Cons` b) = (`Cons` b) . Node <$> pure' a 48 | 49 | -- | Please don't use these lenses to edit the FK fields 50 | _tail :: Lens' (HGraph (a ': b)) (HGraph b) 51 | _tail pure' (a `Cons` b) = (a `Cons`) <$> pure' b 52 | 53 | instance (Arbitrary a) => Arbitrary (Node i is a) where 54 | arbitrary = Node <$> arbitrary 55 | 56 | instance (Show x, Show (HGraph xs)) => Show (HGraph ('(i, is, x) ': xs)) where 57 | show (Cons x y) = "Cons (" <> show x <> ") (" <> show y <> ")" 58 | instance Show (HGraph '[]) where 59 | show Nil = "Nil" 60 | instance (Eq x, Eq (HGraph xs)) => Eq (HGraph ('(i, is, x) ': xs)) where 61 | (Cons x1 xs1) == (Cons x2 xs2) = x1 == x2 && xs1 == xs2 62 | instance Eq (HGraph '[]) where 63 | Nil == Nil = True 64 | 65 | 66 | -- Reimplement a bit of `lens` so that we don't have to import it 67 | 68 | type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t 69 | type Traversal' s a = Traversal s s a a 70 | type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t 71 | type Lens' s a = Lens s s a a 72 | type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) 73 | type Prism' s a = Prism s s a a 74 | type ASetter s t a b = (a -> Identity b) -> s -> Identity t 75 | 76 | _Just :: Prism' (Maybe a) a 77 | _Just = dimap unwrap (either pure (fmap Just)) . right' 78 | where 79 | unwrap = maybe (Left Nothing) Right 80 | 81 | infixl 1 & 82 | (&) :: a -> (a -> b) -> b 83 | (&) = flip ($) 84 | 85 | over :: ASetter s t a b -> (a -> b) -> s -> t 86 | over l f = runIdentity #. l (Identity #. f) 87 | 88 | infixr 4 %~ 89 | (%~) :: ASetter s t a b -> (a -> b) -> s -> t 90 | (%~) = over 91 | -------------------------------------------------------------------------------- /poly-graph/src/Data/Graph/HGraph/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Data.Graph.HGraph.TH where 3 | 4 | import Language.Haskell.TH 5 | 6 | import Data.Graph.HGraph 7 | import Data.Proxy 8 | 9 | declareBases :: [Name] -> DecsQ 10 | declareBases = fmap concat . mapM declareBase 11 | 12 | declareBase :: Name -> DecsQ 13 | declareBase name' = 14 | [d| 15 | type instance Base $name = $name 16 | instance ToBase $name where 17 | base = id 18 | |] 19 | where 20 | name = conT name' 21 | 22 | -- | Shorthand until we get explicit type application 23 | sym :: String -> ExpQ 24 | sym x' = [| Proxy :: Proxy $x |] 25 | where 26 | x = litT (strTyLit x') 27 | -------------------------------------------------------------------------------- /poly-graph/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE Rank2Types #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 15 | {-# OPTIONS_GHC -fno-warn-orphans #-} 16 | 17 | import Test.Hspec 18 | 19 | import Data.Tagged 20 | import Data.Proxy 21 | import GHC.Generics 22 | 23 | import Data.Graph.HGraph 24 | import Data.Graph.HGraph.Instances 25 | import Data.Graph.HGraph.Internal (HGraph(Cons)) 26 | 27 | data Typ = Self | A | B | C 28 | data Node1 (self :: Typ) (other :: Typ) 29 | = Node1 30 | { ident1 :: Tagged self Int 31 | , pointer :: Maybe (Tagged other Int) 32 | } deriving (Show, Eq, Generic) 33 | data Node2 (self :: Typ) (other1 :: Typ) (other2 :: Typ) 34 | = Node2 35 | { ident2 :: Tagged self Int 36 | , pointer1 :: Maybe (Tagged other1 Int) 37 | , pointer2 :: Maybe (Tagged other2 Int) 38 | } deriving (Show, Eq, Generic) 39 | 40 | instance a `FieldPointsAt` b where 41 | fieldPointsAt = const 42 | instance Nullify pointedFrom pointedTo where 43 | nullify Proxy = id 44 | 45 | instance (a `PointsAt` Node1 b c) => PointsAtInternal "NoTyCon" a (Node1 b c) where 46 | pointsAtInternal Proxy a b = a `pointsAt` b 47 | instance (a `PointsAt` Node2 b c d) => PointsAtInternal "NoTyCon" a (Node2 b c d) where 48 | pointsAtInternal Proxy a b = a `pointsAt` b 49 | 50 | main :: IO () 51 | main = hspec $ do 52 | let -- Make sure we support all combinations 53 | node = Node1 (Tagged 1) (Just $ Tagged 1) :: Node1 'Self 'Self 54 | plainToPlain = node `pointsAtDispatcher` node 55 | plainToMaybe = node `pointsAtDispatcher` Just node 56 | 57 | maybeToPlain = Just node `pointsAtDispatcher` node 58 | maybeToMaybe = Just node `pointsAtDispatcher` Just node 59 | 60 | describe "~>" $ do 61 | it "works for simple chains" $ 62 | simpleChain `shouldBe` simpleChain' 63 | it "works for fan outs" $ 64 | fanOut `shouldBe` fanOut' 65 | it "works for fan ins" $ 66 | fanIn `shouldBe` fanIn' 67 | it "works for a complicated mess" $ 68 | inAndOut `shouldBe` inAndOut' 69 | 70 | instance Node1 'Self 'Self `PointsAt` Maybe (Node1 'Self 'Self) where 71 | (Node1 id1 _) `pointsAt` Just (Node1 id2 _) = Node1 id1 (Just id2) 72 | (Node1 id1 _) `pointsAt` Nothing = Node1 id1 Nothing 73 | instance Node1 'Self 'Self `PointsAt` Node1 'Self 'Self where 74 | (Node1 id1 _) `pointsAt` (Node1 id2 _) = Node1 id1 (Just id2) 75 | instance Node1 'A 'B `PointsAt` Node1 'B 'C where 76 | (Node1 ida _) `pointsAt` (Node1 idb _) = Node1 ida (Just idb) 77 | instance Node1 'B 'C `PointsAt` Node2 'C 'A 'B where 78 | (Node1 idb _) `pointsAt` (Node2 idc _ _) = Node1 idb (Just idc) 79 | instance Node2 'C 'A 'B `PointsAt` Node1 'A 'B where 80 | (Node2 idc _ idb) `pointsAt` (Node1 ida _) = Node2 idc (Just ida) idb 81 | instance Node2 'C 'A 'B `PointsAt` Node1 'B 'C where 82 | (Node2 idc ida _) `pointsAt` (Node1 idb _) = Node2 idc ida (Just idb) 83 | 84 | simpleChain :: Line '[Node1 'A 'B, Node1 'B 'C, Node2 'C 'A 'B] 85 | simpleChain = 86 | Node1 1 (Just 6) ~> 87 | Node1 2 Nothing ~> 88 | Node2 3 Nothing Nothing ~> 89 | Nil 90 | 91 | simpleChain' :: Line '[Node1 'A 'B, Node1 'B 'C, Node2 'C 'A 'B] 92 | simpleChain' = 93 | Node (Node1 1 (Just 2)) `Cons` 94 | Node (Node1 2 (Just 3)) `Cons` 95 | Node (Node2 3 Nothing Nothing) `Cons` 96 | Nil 97 | 98 | -- | Graph looks like 99 | -- @ 100 | -- +----->A 101 | -- | 102 | -- ^ 103 | -- C 104 | -- V 105 | -- | 106 | -- +----->B>----->C 107 | -- @ 108 | fanOut :: 109 | HGraph 110 | '[ '("C1", '["A", "B"], Node2 'C 'A 'B) 111 | , '("A", '[], Node1 'A 'B) 112 | , '("B", '["C2"], Node1 'B 'C) 113 | , '("C2", '[], Node2 'C 'A 'B) 114 | ] 115 | fanOut = 116 | Node2 1 (Just 4) Nothing ~> 117 | Node1 2 Nothing ~> 118 | Node1 3 Nothing ~> 119 | Node2 4 Nothing Nothing ~> Nil 120 | 121 | fanOut' :: 122 | HGraph 123 | '[ '("C1", '["A", "B"], Node2 'C 'A 'B) 124 | , '("A", '[], Node1 'A 'B) 125 | , '("B", '["C2"], Node1 'B 'C) 126 | , '("C2", '[], Node2 'C 'A 'B) 127 | ] 128 | fanOut' = 129 | Node (Node2 1 (Just 2) (Just 3)) `Cons` 130 | Node (Node1 2 Nothing) `Cons` 131 | Node (Node1 3 (Just 4)) `Cons` 132 | Node (Node2 4 Nothing Nothing) `Cons` Nil 133 | 134 | -- | Graph looks like 135 | -- @ 136 | -- C>-------+ 137 | -- | 138 | -- V 139 | -- B>------>C 140 | -- ^ 141 | -- | 142 | -- A>-------+ 143 | -- @ 144 | 145 | fanIn :: 146 | HGraph 147 | '[ '("firstC", '["b"], Node2 'C 'A 'B) 148 | , '("a", '["b"], Node1 'A 'B) 149 | , '("b", '["secondC"], Node1 'B 'C) 150 | , '("secondC", '[], Node2 'C 'A 'B) 151 | ] 152 | fanIn = 153 | Node2 1 Nothing Nothing ~> 154 | Node1 2 (Just 1) ~> 155 | Node1 3 (Just 7) ~> 156 | Node2 4 Nothing Nothing ~> Nil 157 | 158 | fanIn' :: 159 | HGraph 160 | '[ '("firstC", '["b"], Node2 'C 'A 'B) 161 | , '("a", '["b"], Node1 'A 'B) 162 | , '("b", '["secondC"], Node1 'B 'C) 163 | , '("secondC", '[], Node2 'C 'A 'B) 164 | ] 165 | fanIn' = 166 | Node (Node2 1 Nothing (Just 3)) `Cons` 167 | Node (Node1 2 (Just 3)) `Cons` 168 | Node (Node1 3 (Just 4)) `Cons` 169 | Node (Node2 4 Nothing Nothing) `Cons` Nil 170 | 171 | -- | Graph looks like 172 | -- @ 173 | -- +------->5 1>------+ 174 | -- | V | 175 | -- | | | 176 | -- | +---------------+| 177 | -- | || 178 | -- ^ VV 179 | -- 2>------>3>------>4>----->7 180 | -- V 181 | -- | 182 | -- | 183 | -- +------->6 184 | -- @ 185 | inAndOut :: 186 | HGraph 187 | [ '(1, '[7], Node1 'Self 'Self) 188 | , '(2, '[3, 5, 6], Node1 'Self 'Self) 189 | , '(3, '[4], Node1 'Self 'Self) 190 | , '(4, '[7], Node1 'Self 'Self) 191 | , '(5, '[7], Node1 'Self 'Self) 192 | , '(6, '[], Node1 'Self 'Self) 193 | , '(7, '[], Node1 'Self 'Self) 194 | ] 195 | inAndOut = 196 | Node1 1 Nothing ~> 197 | Node1 2 Nothing ~> 198 | Node1 3 Nothing ~> 199 | Node1 4 Nothing ~> 200 | Node1 5 Nothing ~> 201 | Node1 6 Nothing ~> 202 | Node1 7 Nothing ~> 203 | Nil 204 | 205 | inAndOut' :: 206 | HGraph 207 | [ '(1, '[7], Node1 'Self 'Self) 208 | , '(2, '[3, 5, 6], Node1 'Self 'Self) 209 | , '(3, '[4], Node1 'Self 'Self) 210 | , '(4, '[7], Node1 'Self 'Self) 211 | , '(5, '[7], Node1 'Self 'Self) 212 | , '(6, '[], Node1 'Self 'Self) 213 | , '(7, '[], Node1 'Self 'Self) 214 | ] 215 | inAndOut' = 216 | Node (Node1 1 (Just 7)) `Cons` 217 | Node (Node1 2 (Just 6)) `Cons` 218 | Node (Node1 3 (Just 4)) `Cons` 219 | Node (Node1 4 (Just 7)) `Cons` 220 | Node (Node1 5 (Just 7)) `Cons` 221 | Node (Node1 6 Nothing) `Cons` 222 | Node (Node1 7 Nothing) `Cons` 223 | Nil 224 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - poly-graph 3 | - poly-graph-persistent 4 | - location: 5 | git: git@github.com:pseudonom/vector-sized 6 | commit: 14ddc62a301292bf33e97b886ed5d09de5590822 7 | resolver: lts-5.9 8 | nix: 9 | pure: false 10 | extra-deps: 11 | - persistent-2.5 12 | --------------------------------------------------------------------------------