├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── dagless.cabal ├── src ├── Dagless.hs ├── Dagless │ └── Types.hs └── Data │ ├── HDagF.hs │ ├── HList.hs │ ├── HListF.hs │ └── Tuple │ ├── Morph.hs │ └── Morph │ └── TH.hs └── test ├── Main.hs └── Test ├── Async.hs └── Energy.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .ghc* 2 | dist* 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Tom Harding 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose 4 | with or without fee is hereby granted, provided that the above copyright notice 5 | and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 9 | FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS 11 | OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 12 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF 13 | THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | #
Dagless 🕶 📚
2 | 3 | > _The doors of Darkplace were opened. Not the **literal** doors of the building – 4 | > most of which were closed – but evil doors, dark doors, doors to the beyond. 5 | > Doors that were hard to shut because they were abstract, and didn't have 6 | > handles. They were more like portals, really. From this day on, I'd have to 7 | > fight these forces of darkness... and deal with the burden of day-to-day 8 | > admin._ - [Dr. Rick Dagless, 9 | M.D.](https://en.wikipedia.org/wiki/Garth_Marenghi%27s_Darkplace) 10 | 11 | Dagless is a DSL for constructing heterogenous computations representable as 12 | [DAGs](https://en.wikipedia.org/wiki/Directed_acyclic_graph). Specifically, it 13 | uses an [IxStateT 14 | transformer](http://hackage.haskell.org/package/indexed-extras/docs/Control-Monad-Indexed-State.html) 15 | to keep track of updates to the graph. When combined with the fabulous 16 | [`do-notation`](http://hackage.haskell.org/package/do-notation) package, 17 | however, this implementation detail is neatly hidden away! 18 | 19 | --- 20 | 21 | See the [Test](https://github.com/i-am-tom/dagless/tree/master/test/Test) 22 | directory for fully-worked examples! 23 | 24 | ```haskell 25 | main collection = compute' do 26 | mass <- fetch @Mass 27 | acceleration <- fetch @Acceleration 28 | 29 | force <- using (mass, acceleration) $ \(m, a) -> do 30 | Mass m' <- m 31 | Acceleration a' <- a 32 | 33 | pure (Force (m' * a')) 34 | 35 | displacement <- fetch @Displacement 36 | 37 | using (force, displacement) $ \(f, d) -> do 38 | Force f' <- f 39 | Displacement d' <- d 40 | 41 | pure (Energy (f' * d')) 42 | ``` 43 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /dagless.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | 3 | author: Tom Harding 4 | category: Control 5 | license-file: LICENSE 6 | license: ISC 7 | maintainer: tomjharding@live.co.uk 8 | name: dagless 9 | version: 0.1.0.0 10 | 11 | library 12 | build-depends: base 13 | , indexed 14 | , indexed-extras 15 | , template-haskell >= 2.16 16 | default-language: Haskell2010 17 | exposed-modules: Dagless 18 | , Dagless.Types 19 | , Data.HDagF 20 | , Data.HList 21 | , Data.HListF 22 | , Data.Tuple.Morph 23 | , Data.Tuple.Morph.TH 24 | hs-source-dirs: src 25 | 26 | test-suite tests 27 | build-depends: async 28 | , base 29 | , dagless 30 | , doctest 31 | , do-notation 32 | , hspec 33 | , indexed 34 | , indexed-extras 35 | , QuickCheck 36 | , random 37 | main-is: Main.hs 38 | other-modules: Test.Async 39 | , Test.Energy 40 | hs-source-dirs: test 41 | type: exitcode-stdio-1.0 42 | default-language: Haskell2010 43 | -------------------------------------------------------------------------------- /src/Dagless.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | {-| 11 | Module : Dagless 12 | Description : An interface for monadically building DAG computations. 13 | Copyright : (c) Tom Harding, 2018 14 | License : MIT 15 | Maintainer : tom.harding@habito.com 16 | Stability : experimental 17 | 18 | @Dagless@ is a module for building directed, acyclic graph computations using 19 | indexed monads. See the @test@ directory for in-depth examples! 20 | 21 | We mentioned the following DAG that we wished to express in `Data.HDagF`: 22 | 23 | @ 24 | TypeInType 25 | | 26 | +-- PolyKinds 27 | | | 28 | +---- +-- KindSignatures 29 | | 30 | +-- DataKinds 31 | @ 32 | 33 | Sadly, the raw 'HDagF' interface made this quite ugly. However, we can produce 34 | much cleaner results with our DSL. Starting with the types: 35 | 36 | @ 37 | data DataKinds = DataKinds 38 | data KindSignatures = KindSignatures 39 | data PolyKinds = PolyKinds 40 | data TypeInType = TypeInType 41 | @ 42 | 43 | We'll use the magic of `do-notation` to avoid any hassle with indexed monads: 44 | 45 | @ 46 | {-# LANGUAGE DataKinds, RebindableSyntax #-} 47 | import Prelude hiding ((>>=), (>>), pure, return) 48 | import qualified Language.Haskell.DoNotation 49 | @ 50 | 51 | We can now build the DAG using the monadic interface: 52 | 53 | @ 54 | typeInType :: m (HDagF f '[TypeInType, PolyKinds, DataKinds, KindSignatures]) 55 | typeInType = graph $ do 56 | ks <- persist (pure KindSignatures) 57 | dk <- persist (pure DataKinds) 58 | 59 | pk <- using ks \_ -> 60 | pure PolyKinds 61 | 62 | using (pk, ks, dk) \_ -> 63 | pure TypeInType 64 | @ 65 | 66 | Much neater! 67 | - 68 | -} 69 | module Dagless 70 | ( module T 71 | 72 | , In 73 | , Witness 74 | 75 | , persist 76 | , using 77 | ) where 78 | 79 | import Control.Monad.Indexed.State (imodify) 80 | import Dagless.Types as T 81 | import Data.Functor (($>)) 82 | import Data.HDagF (AreChildrenOf (..), HDagF (..), In) 83 | import Data.HList (HList (..)) 84 | import Data.HListF (FactorIn (..), FactorOut, HListF (HNilF)) 85 | import Data.Kind (Constraint, Type) 86 | import Data.Tuple.Morph (Morph (..)) 87 | 88 | -- | Witness that something has been added to the DAG. We hide the constructor 89 | -- so users can't create their own witnesses. What this means is that the 90 | -- type errors a user sees /shouldn't/ be from the DAG constraints - they 91 | -- should be type mismatches between the witness and the node function's input. 92 | -- In short, requiring these be passed around should mean some better compiler 93 | -- errors. 94 | 95 | data Witness (a :: Type) = Witness -- Hopefully compiler-erased? 96 | 97 | -- | We can't pass a tuple to 'using' if we only have one dependency, so this 98 | -- orphan instance means that we can pass a single 'Witness' and still have 99 | -- everything work. 100 | 101 | instance Morph '[Witness x] (Witness x) where 102 | fromTuple x = x :> HNil 103 | toTuple (x :> _) = x 104 | 105 | -- | DAGs are a set of nodes with (directed, acyclic) dependencies on zero or 106 | -- more other nodes in the set. If they have zero nodes, we can think of them 107 | -- as the "leaf" of a tree, and thus their children are effectively constant. 108 | -- 'persist' lets us add a value into the DAG of a 'DaglessT' computation, 109 | -- assuming that no other node exists of the same type. @newtype@ all the 110 | -- things! 111 | 112 | persist 113 | :: (addition `In` nodes ~ False, Monad m) 114 | => f addition -> DaglessT f m nodes (addition ': nodes) (Witness addition) 115 | 116 | persist = fmap (const Witness) . DaglessT . imodify . HNodeF @'[] . const 117 | 118 | -- | If your node is /not/ a leaf, and does in fact have requirements on other 119 | -- nodes in the DAG, this function provides a cleaner syntax for accessing 120 | -- them. When nodes are persisted, they produce a 'Witness', which acts as a 121 | -- proof that something exists within the DAG as a result to be calculated. 122 | -- 'using' takes an n-ary (flat) tuple of these witnesses, and a function that 123 | -- produces your node given an equivalent tuple of the calculated values. 124 | -- Again, the examples might be more useful here. 125 | 126 | using 127 | :: ( Morph proxyTypes proxyTuple 128 | , FactorOut Witness proxyTypes dependencies 129 | , FactorIn f dependencies fTypes 130 | , Morph fTypes inputTuple 131 | 132 | , addition `In` nodes ~ 'False 133 | , dependencies `AreChildrenOf` nodes 134 | 135 | , Monad m 136 | ) 137 | => proxyTuple 138 | -> (inputTuple -> f addition) 139 | -> DaglessT f m nodes (addition ': nodes) (Witness addition) 140 | 141 | using _ f 142 | = fmap (const Witness) . DaglessT . imodify 143 | $ HNodeF (f . toTuple . refactor) 144 | -------------------------------------------------------------------------------- /src/Dagless/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GeneralisedNewtypeDeriving #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | {-| 6 | Module : Dagless.Types 7 | Description : The types used for the Dagless transformer and its derivatives. 8 | Copyright : (c) Tom Harding, 2018 9 | License : MIT 10 | Maintainer : tom.harding@habito.com 11 | Stability : experimental 12 | 13 | This module isn't super interesting, and you'll get more from the 'Dagless' 14 | module directly. Here, we describe 'DaglessT', 'Dagless' (@DaglessT Identity@), 15 | and their prime variations. Both 'DaglessT'' and 'Dagless'' refer to instances 16 | for which the context of the DAG computations and the context of the DSL are 17 | equivalent. 18 | -} 19 | module Dagless.Types where 20 | 21 | import Control.Monad (join) 22 | import qualified Control.Monad.Indexed as Ix 23 | import Control.Monad.Indexed.State (IxStateT (..)) 24 | import Control.Monad.Indexed.Trans (IxMonadTrans (..)) 25 | import Data.Coerce (coerce) 26 | import Data.Functor.Identity (Identity (..)) 27 | import Data.HDagF (HDagF (..), evaluate) 28 | 29 | -- | The Dagless transformer. Describes a computation that, as well as the 30 | -- side-effects described by @m@, updates the nodes within a DAG. See the tests 31 | -- folder for more examples. 32 | -- 33 | -- - @m@ is the monad we're transforming. 34 | -- - @f@ is the context in which the DAG nodes are evaluated. 35 | -- - @pre@ is the set of nodes in the DAG /before/ the computation. 36 | -- - @post@ is the set of nodes in the DAG /after/ the computation. 37 | -- - @a@ is the value inside the DaglessT context. 38 | 39 | newtype DaglessT f m pre post a 40 | = DaglessT { runDaglessT :: IxStateT m (HDagF f pre) (HDagF f post) a } 41 | deriving Functor 42 | 43 | instance Monad m => Ix.IxFunctor (DaglessT f m) where 44 | imap f (DaglessT xs) = DaglessT (Ix.imap f xs) 45 | 46 | instance Monad m => Ix.IxPointed (DaglessT f m) where 47 | ireturn x = DaglessT (Ix.ireturn x) 48 | 49 | instance Monad m => Ix.IxApplicative (DaglessT f m) where 50 | iap (DaglessT fs) (DaglessT xs) = DaglessT (Ix.iap fs xs) 51 | 52 | instance Monad m => Ix.IxMonad (DaglessT f m) where 53 | ibind f (DaglessT xs) = DaglessT (xs Ix.>>>= runDaglessT . f) 54 | 55 | instance IxMonadTrans (DaglessT f) where 56 | ilift = DaglessT . ilift 57 | 58 | -- | Often, your DAG computations and your state computations will require the 59 | -- same transformer stack of side-effects. To accommodate this, we have a type 60 | -- synonyf mor stacks in which the DAG node context and the transformer context 61 | -- are the same. 62 | 63 | type DaglessT' m pre post a 64 | = DaglessT m m pre post a 65 | 66 | -- | If we're not interested in building our transformer stack any further, the 67 | -- 'Dagless' monad simply sets the underlying monad to 'Identity'. 68 | 69 | type Dagless f pre post a 70 | = DaglessT Identity f pre post a 71 | 72 | -- | If our DAG computations are pure, we also don't particularly care about 73 | -- the @f@ context, and so we can set that to `Identity` as well, giving us a 74 | -- type that isn't anywhere near as scary. 75 | 76 | type Dagless' pre post a 77 | = DaglessT' Identity pre post a 78 | 79 | -- | Extract the root node of the DAG produced in a 'DaglessT' computation. 80 | -- Note the two contexts: the transformer context @m@, and the DAG computation 81 | -- context @f@. 82 | 83 | compute :: (Functor f, Functor m) => DaglessT f m '[] (x ': xs) a -> m (f x) 84 | compute = fmap (evaluate . snd) . (`runIxStateT` HEmptyF) . runDaglessT 85 | 86 | -- | When the two contexts are identical, 'compute' returns two layers of 87 | -- context unnecessarily. This function takes a 'DaglessT'', and calls 'join' 88 | -- on the result of 'compute'. We edge closer and closer to the Fairbairn 89 | -- threshold. 90 | 91 | compute' :: Monad m => DaglessT' m '[] (x ': xs) a -> m x 92 | compute' = join . compute 93 | 94 | -- | Extract the 'HDagF' from a 'DaglessT' transformer. 95 | 96 | graph :: Functor m => DaglessT f m '[] xs a -> m (HDagF f xs) 97 | graph = fmap snd . (`runIxStateT` HEmptyF) . runDaglessT 98 | -------------------------------------------------------------------------------- /src/Data/HDagF.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | {-| 10 | Module : Data.HDagF 11 | Description : A directed, acyclic graph expressed as a constrained list. 12 | Copyright : (c) Tom Harding, 2018 13 | License : MIT 14 | Maintainer : tom.harding@habito.com 15 | Stability : experimental 16 | 17 | DAGs are a tricky thing to express in a way that allows the compiler to help 18 | you. Luckily for me, Twan van Laarhoven didn't just devote his a to lenses: in 19 | https://www.twanvl.nl/blog/haskell/dependently-typed-dags, a nice approach to 20 | this problem is discussed, using @Vector@ and @Fin@ to guarantee that a valid 21 | index is given for every dependency. 22 | 23 | This module extends this idea to heterogeneous DAGs. Of course, @Fin@ is no 24 | longer a good enough index type, as we need to know /which/ child is being 25 | indexed. To do this, 'HDagF' requires that all nodes be /unique/ types, and 26 | thus we can unambiguously reference required nodes by their types. 27 | 28 | Let's imagine we want to build a DAG to show which GHC language extensions are 29 | implied by others. We'll think specifically about the little tree formed by 30 | @TypeInType@: 31 | 32 | @ 33 | TypeInType 34 | | 35 | +-- PolyKinds 36 | | | 37 | +---- +-- KindSignatures 38 | | 39 | +-- DataKinds 40 | @ 41 | 42 | According to the docs, @TypeInType@ implies @PolyKinds@, @KindSignatures@, and 43 | @DataKinds@. However, @PolyKinds@ also implies @KindSignatures@, so we have a 44 | nice little DAG! 45 | 46 | Let's first create some types: 47 | 48 | >>> data DataKinds = DataKinds 49 | >>> data KindSignatures = KindSignatures 50 | >>> data PolyKinds = PolyKinds 51 | >>> data TypeInType = TypeInType 52 | 53 | .. and switch on some extensions: 54 | 55 | >>> :set -XDataKinds -XTypeApplications 56 | 57 | Now, let's express it with an HDagF: 58 | 59 | >>> :{ 60 | >>> typeInType 61 | >>> :: Applicative f 62 | >>> => HDagF f '[TypeInType, PolyKinds, DataKinds, KindSignatures] 63 | >>> typeInType 64 | >>> = HNodeF @'[DataKinds, PolyKinds, KindSignatures] (\_ -> pure TypeInType) 65 | >>> . HNodeF @'[KindSignatures] (\_ -> pure PolyKinds) 66 | >>> . HNodeF @'[] (\_ -> pure DataKinds) 67 | >>> . HNodeF @'[] (\_ -> pure KindSignatures) 68 | >>> $ HEmptyF 69 | >>> :} 70 | 71 | So, it's a bit ugly, but hopefully parseable. We type-apply the dependencies of 72 | the node we're creating, and then pass a function that performs some 73 | computation involving those values. Better examples can be found in the 'test/' 74 | directory. 75 | -} 76 | module Data.HDagF 77 | ( AreChildrenOf (..) 78 | 79 | , HDagF (..) 80 | , HListF (..) 81 | 82 | , In 83 | , evaluate 84 | ) where 85 | 86 | import Data.HListF (HListF (..)) 87 | import Data.Kind (Type) 88 | 89 | -- | Test for an element's presence within a type-level list. 90 | -- 91 | -- >>> :set -XDataKinds -XTypeOperators 92 | -- >>> :kind! Bool `In` '[] 93 | -- Bool `In` '[] :: Bool 94 | -- = 'False 95 | -- 96 | -- >>> :kind! Bool `In` '[String, Int, Bool] 97 | -- Bool `In` '[String, Int, Bool] :: Bool 98 | -- = 'True 99 | 100 | type family (x :: k) `In` (xs :: [k]) :: Bool where 101 | x `In` (x ': xs) = 'True 102 | x `In` (_ ': xs) = x `In` xs 103 | _ `In` _ = 'False 104 | 105 | -- | A heterogeneous, directed, acyclic graph, in which values are evaluated in 106 | -- some @f@ context. 107 | -- 108 | -- >>> :set -XFlexibleContexts -XGADTs -XTypeApplications 109 | -- >>> let first = HNodeF @'[ ] (\ _ -> [25 :: Int]) 110 | -- >>> let second = HNodeF @'[Int] (\(xs :$> HNilF) -> map show xs) 111 | -- 112 | -- Here, we've defined a node, @second@, that depends on the presence of some 113 | -- 'Int' node. Luckily, @first@ is an @Int@ node! 114 | -- 115 | -- >>> :t second $ first $ HEmptyF 116 | -- second $ first $ HEmptyF :: HDagF [] '[String, Int] 117 | 118 | data HDagF (f :: Type -> Type) (xs :: [Type]) where 119 | HEmptyF 120 | :: HDagF f '[] 121 | 122 | HNodeF 123 | :: (cs `AreChildrenOf` xs, x `In` xs ~ False) 124 | => (HListF f cs -> f x) -> HDagF f xs -> HDagF f (x ': xs) 125 | 126 | -- | Extract a child node from a DAG by first evaluating its dependencies, and 127 | -- then calculating its own value. 128 | -- 129 | -- >>> :set -XGADTs -XTypeApplications 130 | -- >>> extract @Int (HNodeF @'[] (\HNilF -> [2 :: Int]) HEmptyF) 131 | -- [2] 132 | 133 | class (x :: Type) `IsAChildOf` (xs :: [Type]) where 134 | extract :: HDagF f xs -> f x 135 | 136 | instance x `IsAChildOf` (x ': xs) where 137 | extract = evaluate 138 | 139 | instance {-# OVERLAPPABLE #-} x `IsAChildOf` xs 140 | => x `IsAChildOf` (y ': xs) where 141 | extract (HNodeF _ tail) = extract tail 142 | 143 | -- | Extract /multiple/ children from a DAG via repeated use of @IsAChildOf@. 144 | -- 145 | -- >>> :set -XFlexibleContexts -XGADTs -XTypeApplications 146 | -- >>> let first = HNodeF @'[ ] (\ _ -> [2, 4 :: Int]) 147 | -- >>> let second = HNodeF @'[Int] (\(xs :$> HNilF) -> map show xs ) 148 | -- 149 | -- >>> let plucked = extracts @'[Int, String] (second $ first $ HEmptyF) 150 | -- >>> :t plucked 151 | -- plucked :: HListF [] '[Int, String] 152 | -- 153 | -- >>> import Data.Function ((&)) 154 | -- >>> plucked & \(i :$> s :$> HNilF) -> mconcat (map show i ++ s) 155 | -- "2424" 156 | 157 | class (cs :: [Type]) `AreChildrenOf` (xs :: [Type]) where 158 | extracts :: HDagF f xs -> HListF f cs 159 | 160 | instance '[] `AreChildrenOf` xs where 161 | extracts _ = HNilF 162 | 163 | instance (c `IsAChildOf` xs, cs `AreChildrenOf` xs) 164 | => (c ': cs) `AreChildrenOf` xs where 165 | extracts xs = extract xs :$> extracts xs 166 | 167 | -- | Evaluate a DAG computation. We recursively evaluate the children of the 168 | -- node to produce the inputs to its function, and then... well, run that 169 | -- function! Nothing too exciting. 170 | -- 171 | -- >>> let first = HNodeF @'[ ] (\ _ -> [2, 4 :: Int]) 172 | -- >>> let second = HNodeF @'[Int] (\(xs :$> HNilF) -> map show xs ) 173 | -- 174 | -- >>> evaluate (second $ first $ HEmptyF) 175 | -- ["2","4"] 176 | 177 | evaluate :: HDagF f (x ': xs) -> f x 178 | evaluate (HNodeF f tail) = f (extracts tail) 179 | -------------------------------------------------------------------------------- /src/Data/HList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | 13 | {-| 14 | Module : Data.HList 15 | Description : A nice, neat HList. 16 | Copyright : (c) Tom Harding, 2018 17 | License : MIT 18 | Maintainer : tom.harding@habito.com 19 | Stability : experimental 20 | 21 | This module defines a heterogeneous list type. Any types can be stored in the 22 | list, and the type itself is indexed by the types contained within. This module 23 | also defines functions for extracting values /and/ folding an HList in which 24 | all inhabitant types implement some constraint. 25 | -} 26 | module Data.HList where 27 | 28 | import Data.Kind (Constraint, Type) 29 | import Prelude hiding (foldMap) 30 | 31 | -- | A heterogeneous list, indexed by the types that it contains. We define the 32 | -- ':>' notation for @Cons@, which hopefully makes uses a bit neater. 33 | 34 | data HList (xs :: [Type]) where 35 | HNil :: HList '[ ] 36 | (:>) :: x -> HList xs -> HList (x ': xs) 37 | 38 | infixr 3 :> 39 | 40 | -- | Pluck a type from an HList. The constraint ensures that the type exists 41 | -- within the list, and thus it is a total function. 42 | -- 43 | -- >>> :set -XTypeApplications 44 | -- >>> let example = True :> 3 :> "hello" :> HNil 45 | -- 46 | -- >>> pluck @Bool example 47 | -- True 48 | -- 49 | -- >>> pluck @String example 50 | -- "hello" 51 | -- 52 | -- >>> pluck @(()) example 53 | -- ... 54 | -- ... No instance for (PluckedFrom ...) 55 | -- ... 56 | 57 | class (x :: Type) `PluckedFrom` (xs :: [Type]) where 58 | pluck :: HList xs -> x 59 | 60 | instance x `PluckedFrom` (x ': xs) where 61 | pluck (head :> _) = head 62 | 63 | instance {-# OVERLAPPABLE #-} x `PluckedFrom` xs 64 | => x `PluckedFrom` (y ': xs) where 65 | pluck (_ :> tail) = pluck tail 66 | 67 | -- | Fold an HList. Assuming all the elements of the list satisfy some 68 | -- constraint, we should be able to "fold" over the list according to some 69 | -- monoid value produced using that constraint. 70 | -- 71 | -- >>> let example = True :> 3 :> "hello" :> HNil 72 | -- >>> foldMap @Show (pure @[] . show) example 73 | -- ["True","3","\"hello\""] 74 | -- 75 | -- We can also fold over a homogeneous HList using an equality constraint, 76 | -- allowing us to recover the traditional list folds: 77 | -- 78 | -- >>> import Data.Monoid 79 | -- >>> foldMap @((~) Int) Sum (3 :> 2 :> 1 :> HNil) 80 | -- Sum {getSum = 6} 81 | -- 82 | -- Finally, we can use 'Data.Coerce.coerce' for some truly interesting 83 | -- operations: 84 | -- 85 | -- >>> import Data.Coerce 86 | -- >>> let example = Any False :> False :> All True :> HNil 87 | -- >>> foldMap @(Coercible Any) (coerce @_ @Any) example 88 | -- Any {getAny = True} 89 | 90 | class (c :: Type -> Constraint) `Folds` (xs :: [Type]) where 91 | foldMap :: Monoid m => (forall x. c x => x -> m) -> HList xs -> m 92 | 93 | instance anything `Folds` '[] where 94 | foldMap _ HNil = mempty 95 | 96 | instance (c x, c `Folds` xs) => c `Folds` (x ': xs) where 97 | foldMap f (x :> xs) = f x <> foldMap @c f xs 98 | -------------------------------------------------------------------------------- /src/Data/HListF.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | {-| 15 | Module : Data.HListF 16 | Description : An HList indexed by the context around every value within. 17 | Copyright : (c) Tom Harding, 2018 18 | License : MIT 19 | Maintainer : tom.harding@habito.com 20 | Stability : experimental 21 | 22 | A regular 'HList' contains a number of values of varying types, which are part 23 | of the type-level index. An HListF extends this idea by specifying a context in 24 | which all the values are wrapped. For example, notice here that our functor is 25 | @[]@, which is the first index of the 'HListF' type. The second is the list of 26 | @[]@-wrapped types that exist /within/ the list: 27 | 28 | >>> :t [0 ..] :$> [True, False] :$> [()] :$> HNilF 29 | [0 ..] :$> [True, False] :$> [()] :$> HNilF 30 | :: (Num x, Enum x) => HListF [] '[x, Bool, ()] 31 | -} 32 | module Data.HListF where 33 | 34 | import Data.HList (HList (..)) 35 | import Data.Kind (Constraint, Type) 36 | 37 | -- | A heterogeneous list of context-wrapped values, indexed by their types. 38 | -- The first index is the context in which these values are wrapped. 39 | 40 | data HListF (f :: Type -> Type) (xs :: [Type]) where 41 | HNilF :: HListF f '[ ] 42 | (:$>) :: f x -> HListF f xs -> HListF f (x ': xs) 43 | 44 | infixr 3 :$> 45 | 46 | -- | Transform an 'HList' into an 'HListF' by factoring out some common 47 | -- context. If all the values in the 'HList' are wrapped in some context @f@, 48 | -- then it is isomorphic to some @HListF f@. 49 | -- 50 | -- >>> :t factor @[] ([0 ..] :> [True, False] :> [()] :> HNil) 51 | -- factor @[] ([0 ..] :> [True, False] :> [()] :> HNil) 52 | -- :: (Num a, Enum a) => HListF [] '[a, Bool, ()] 53 | 54 | class FactorOut (f :: Type -> Type) (is :: [Type]) (os :: [Type]) 55 | | f is -> os, f os -> is where 56 | factor :: HList is -> HListF f os 57 | 58 | instance FactorOut f '[] '[] where 59 | factor HNil = HNilF 60 | 61 | instance FactorOut f xs ys => FactorOut f (f x ': xs) (x ': ys) where 62 | factor (x :> xs) = x :$> factor xs 63 | 64 | -- | 'FactorIn' is a bad name for the opposite of 'FactorOut': here, we take an 65 | -- 'HListF' and turn it into an 'HList' by "refactoring" the @f@ into each 66 | -- type. It's not particularly exciting. 67 | -- 68 | -- >>> :t refactor ([0 ..] :$> [True, False] :$> [()] :$> HNilF) 69 | -- refactor ([0 ..] :$> [True, False] :$> [()] :$> HNilF) 70 | -- :: (Num x, Enum x) => HList '[[x], [Bool], [()]] 71 | 72 | class FactorIn (f :: Type -> Type) (is :: [Type]) (os :: [Type]) 73 | | f is -> os, f os -> is where 74 | refactor :: HListF f is -> HList os 75 | 76 | instance FactorIn f '[] '[] where 77 | refactor HNilF = HNil 78 | 79 | instance FactorIn f xs ys => FactorIn f (x ': xs) (f x ': ys) where 80 | refactor (x :$> xs) = x :> refactor xs 81 | 82 | -- | Pluck a type from an 'HListF'. The resultant value will be wrapped in the 83 | -- context indexing the 'HListF', and the constraint ensures that it's total. 84 | -- 85 | -- >>> pluckF @Bool ([0 ..] :$> [True, False] :$> [()] :$> HNilF) 86 | -- [True,False] 87 | 88 | class (x :: Type) `PluckedFromF` (xs :: [Type]) where 89 | pluckF :: HListF f xs -> f x 90 | 91 | instance x `PluckedFromF` (x ': xs) where 92 | pluckF (head :$> _) = head 93 | 94 | instance {-# OVERLAPPABLE #-} x `PluckedFromF` xs 95 | => x `PluckedFromF` (y ': xs) where 96 | pluckF (_ :$> tail) = pluckF tail 97 | 98 | -- | Fold an HListF according to some constraint. Note that we constrain the 99 | -- inner value, _not_ the context-wrapped value. 100 | -- 101 | -- >>> foldF @Show (fmap show) ([0 .. 5] :$> [True, False] :$> [()] :$> HNilF) 102 | -- ["0","1","2","3","4","5","True","False","()"] 103 | 104 | class (c :: Type -> Constraint) `FoldsF` (xs :: [Type]) where 105 | foldF :: Monoid m => (forall x. c x => f x -> m) -> HListF f xs -> m 106 | 107 | instance anything `FoldsF` '[] where 108 | foldF _ HNilF = mempty 109 | 110 | instance (c x, c `FoldsF` xs) => c `FoldsF` (x ': xs) where 111 | foldF f (x :$> xs) = f x <> foldF @c f xs 112 | -------------------------------------------------------------------------------- /src/Data/Tuple/Morph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-| 8 | Module : Data.Tuple.Morph 9 | Description : An interface for tuple manipulations using HLists. 10 | Copyright : (c) Tom Harding, 2018 11 | License : MIT 12 | Maintainer : tom.harding@habito.com 13 | Stability : experimental 14 | 15 | Shout out http://hackage.haskell.org/package/tuple-morph - I'll be dropping 16 | this file and adding the dependency as soon as I've proven the concept and had 17 | time to PR the library for 8.6.*. 18 | -} 19 | module Data.Tuple.Morph where 20 | 21 | import Data.HList (HList (..)) 22 | import Data.Kind (Type) 23 | import Data.Tuple.Morph.TH (makeMorphInstance) 24 | 25 | -- | Convert between @Tuple@ and 'HList'. This allows us to manipulate tuples 26 | -- in a much more intuitive and "regular" way. 27 | -- 28 | -- >>> :t fromTuple ("hello", True) 29 | -- fromTuple ("hello", True) :: HList '[[Char], Bool] 30 | -- 31 | -- >>> :t toTuple ("hello" :> True :> HNil) 32 | -- toTuple ("hello" :> True :> HNil) :: ([Char], Bool) 33 | 34 | class Morph (types :: [Type]) (tuple :: Type) 35 | | types -> tuple, tuple -> types where 36 | fromTuple :: tuple -> HList types 37 | toTuple :: HList types -> tuple 38 | 39 | $(traverse makeMorphInstance [2 .. 62]) 40 | -------------------------------------------------------------------------------- /src/Data/Tuple/Morph/TH.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Data.Tuple.Morph.TH 3 | Description : The dirty @TemplateHaskell@ internals of tuple-morphing. 4 | Copyright : (c) Tom Harding, 2018 5 | License : MIT 6 | Maintainer : tom.harding@habito.com 7 | Stability : experimental 8 | 9 | https://github.com/i-am-tom/learn-me-a-haskell/blob/master/src/Utils/Tuple/TH.hs 10 | 11 | This module is ripped straight from my other repository, where you'll find a 12 | lot more documentation. Again, this will be replaced by tuple-morph as soon 13 | as possible. 14 | -} 15 | module Data.Tuple.Morph.TH where 16 | 17 | import Data.Foldable (foldl') 18 | import Data.Function ((&)) 19 | import Language.Haskell.TH 20 | 21 | -- | The type of the tuple in the morph instance. 22 | mkTupleT :: [Name] -> Type 23 | mkTupleT xs = foldl' (\head -> AppT head . VarT) (TupleT (length xs)) xs 24 | 25 | -- | The type of the HList in the morph instance. 26 | mkHListT :: [Name] -> Type 27 | mkHListT = foldr (AppT . AppT PromotedConsT . VarT) PromotedNilT 28 | 29 | -- | The tuple pattern match. 30 | mkTupleP :: [Name] -> Pat 31 | mkTupleP = TupP . fmap VarP 32 | 33 | -- | The HList pattern match. 34 | mkHListP :: [Name] -> Pat 35 | mkHListP (x : xs) = ConP (mkName ":>" ) [VarP x, mkHListP xs] 36 | mkHListP [] = ConP (mkName "HNil") [] 37 | 38 | -- | The tuple expression. 39 | mkTupleE :: [Name] -> Exp 40 | mkTupleE = TupE . fmap (Just . VarE) 41 | 42 | -- | The HList expression. 43 | mkHListE :: [Name] -> Exp 44 | mkHListE = foldr (AppE . AppE cons . VarE) nil 45 | where 46 | nil = ConE (mkName "HNil") 47 | cons = ConE (mkName ":>" ) 48 | 49 | -- | All together now! 50 | makeMorphInstance :: Int -> Q Dec 51 | makeMorphInstance count = do 52 | names <- traverse (\_ -> newName "t") [1 .. count] 53 | 54 | let hlistT = mkHListT names 55 | hlistP = mkHListP names 56 | hlistE = mkHListE names 57 | 58 | tupleT = mkTupleT names 59 | tupleP = mkTupleP names 60 | tupleE = mkTupleE names 61 | 62 | morph = ConT (mkName "Morph") 63 | head = AppT (AppT morph hlistT) tupleT 64 | 65 | pure $ InstanceD Nothing [] head 66 | [ FunD (mkName "fromTuple") [ Clause [ tupleP ] (NormalB hlistE) [] ] 67 | , FunD (mkName "toTuple") [ Clause [ hlistP ] (NormalB tupleE) [] ] 68 | ] 69 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | module Main where 3 | 4 | import Data.HList (HList (..)) 5 | import System.IO.Unsafe (unsafePerformIO) 6 | import Test.DocTest 7 | import qualified Test.Async as Async 8 | import qualified Test.Energy as Energy 9 | import Test.Hspec 10 | import Test.QuickCheck 11 | 12 | main :: IO () 13 | main = do 14 | -- The documentation in the src/ folder contains many of the tests. The 15 | -- 'doctest' program parses the source files for examples, and runs them! 16 | 17 | doctest ["src", "test"] 18 | 19 | -- We also have some examples in this @test/@ directory, which we test with 20 | -- Hspec. Possibly not /much/ use in property-testing here, but it's 21 | -- certainly better than nothing. 22 | 23 | hspec do 24 | 25 | -- The Energy example demonstrates a fully context-polymorphic DAG, meaning 26 | -- that all the computations are totally pure and without side-effects. The 27 | -- calculation is fairly straightforward, but introduces a couple of 28 | -- dependencies: we calculate @Force@ using @Mass@ and @Acceleration@, then 29 | -- we calculate @Energy@ using @Force@ and @Displacement@. If everything 30 | -- works out, this is just a long-winded way of multiplying the original 31 | -- three values! 32 | 33 | describe "Energy" do 34 | it "Calculates the correct energy value" $ property \a m d -> do 35 | value <- Energy.main $ Energy.Acceleration a 36 | :> Energy.Mass m 37 | :> Energy.Displacement d 38 | :> HNil 39 | 40 | Energy.getE value `shouldBe` (a * m * d) 41 | 42 | -- The Async example is a little more interesting. We explicitly encode the 43 | -- dependencies in our asynchronous computations, making maximal use of 44 | -- parallelism by default. We've used 'concurrently' explicitly in the 45 | -- 'using' functions, but we needn't: we could just as easily hide this 46 | -- behaviour behind a custom 'using' function and expose a DSL in which 47 | -- dependencies were automatically evaluated in parallel! 48 | 49 | describe "Async" do 50 | it "Properly schedules asynchronous actions" $ property \a b c d -> 51 | unsafePerformIO (Async.main a b c d) 52 | == case compare (a + b) (c + d) of 53 | GT -> Async.TeamA 54 | EQ -> Async.Draw 55 | LT -> Async.TeamB 56 | -------------------------------------------------------------------------------- /test/Test/Async.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RebindableSyntax #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | module Test.Async where 10 | 11 | import Control.Concurrent (threadDelay) 12 | import Control.Concurrent.Async (concurrently) 13 | import Control.Monad.Indexed.Trans (ilift) 14 | import Dagless (DaglessT', In, Witness, compute', persist, using) 15 | import Data.Coerce (coerce, Coercible) 16 | import Language.Haskell.DoNotation ((>>=), (>>), pure, return) 17 | import Prelude hiding ((>>=), (>>), pure, return) 18 | import System.Random (randomIO) 19 | 20 | -- In this example, we'll imagine some networked game between four people 21 | -- divided into two teams. The goal here is to add the scores per team, and 22 | -- then see which team has the most points. We'll throw in a little bit of 23 | -- thread delay just to make it more interesting. 24 | 25 | -- We're going to need some new types for our DAG. First, players' individual 26 | -- scores. 27 | 28 | newtype Player1Total = Player1Total Int 29 | newtype Player2Total = Player2Total Int 30 | newtype Player3Total = Player3Total Int 31 | newtype Player4Total = Player4Total Int 32 | 33 | -- Secondly, the team's scores... 34 | 35 | newtype TeamATotal = TeamATotal Int 36 | newtype TeamBTotal = TeamBTotal Int 37 | 38 | -- Finally, the result of the match! 39 | 40 | data Result = TeamA | TeamB | Draw 41 | deriving Eq 42 | 43 | main :: Int -> Int -> Int -> Int -> IO Result 44 | main x1 x2 x3 x4 = compute' do 45 | -- We register all 4 as things we need. I've called it 'mimic' because it's 46 | -- just mimicking network delay, and not actually calculating anything. 47 | 48 | p1 <- mimic @Player1Total x1 49 | p2 <- mimic @Player2Total x2 50 | p3 <- mimic @Player3Total x3 51 | p4 <- mimic @Player4Total x4 52 | 53 | -- Get the A-team scores... 54 | teamA <- using (p1, p2) \(p1, p2) -> do 55 | (Player1Total p1', Player2Total p2') <- concurrently p1 p2 56 | pure (TeamATotal (p1' + p2')) 57 | 58 | -- Get the B-team scores... 59 | teamB <- using (p3, p4) \(p3, p4) -> do 60 | (Player3Total p3', Player4Total p4') <- concurrently p3 p4 61 | pure (TeamBTotal (p3' + p4')) 62 | 63 | -- Finally, we can calculate the winner! 64 | using (teamA, teamB) \(tA, tB) -> do 65 | (TeamATotal tA', TeamBTotal tB') <- concurrently tA tB 66 | 67 | pure case compare tA' tB' of 68 | GT -> TeamA 69 | LT -> TeamB 70 | EQ -> Draw 71 | 72 | where 73 | 74 | -- Mimic some server delay. We'll sleep for a random number of 75 | -- milliseconds, then yield the original value. 76 | mimic 77 | :: forall x xs. (Coercible x Int, x `In` xs ~ False) 78 | => Int -> DaglessT' IO xs (x ': xs) (Witness x) 79 | 80 | mimic x = do 81 | sleep <- ilift randomIO 82 | ilift (threadDelay (sleep `mod` 50)) 83 | 84 | persist (pure (coerce x)) 85 | -------------------------------------------------------------------------------- /test/Test/Energy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE RebindableSyntax #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | module Test.Energy where 10 | 11 | import Dagless (DaglessT', Witness, compute', persist, using) 12 | import Data.HDagF (In) 13 | import Data.HList (HList (..), PluckedFrom (..)) 14 | import Language.Haskell.DoNotation ((>>=), pure, return) 15 | import Prelude hiding ((>>=), (>>), pure, return) 16 | 17 | -- We're going to build a DAG to calculate the energy output of an object at a 18 | -- given mass accelerating at a given rate over a given displacement. I'm 19 | -- afraid my understanding of mechanics means that we're going to have to 20 | -- assume it's a perfectly spherical item in a vacuum, etc etc. First, we're 21 | -- going to need a bunch of types: 22 | 23 | newtype Acceleration = Acceleration { getA :: Double } 24 | newtype Displacement = Displacement { getD :: Double } 25 | newtype Energy = Energy { getE :: Double } deriving Show 26 | newtype Force = Force { getF :: Double } 27 | newtype Mass = Mass { getM :: Double } 28 | 29 | -- To make the example neater, let's be explicit about the types that we're 30 | -- expecting as input: 31 | 32 | type Input = '[ Acceleration, Mass, Displacement ] 33 | 34 | -- Now everything's in place, let's look at a little computation. Note that, as 35 | -- we don't care about our context, this computation is polymorphic in its 36 | -- monad. 37 | 38 | main :: Monad m => HList Input -> m Energy 39 | main collection = compute' do 40 | mass <- fetch @Mass 41 | acceleration <- fetch @Acceleration 42 | 43 | force <- using (mass, acceleration) $ \(m, a) -> do 44 | Mass m' <- m 45 | Acceleration a' <- a 46 | 47 | pure (Force (m' * a')) 48 | 49 | displacement <- fetch @Displacement 50 | 51 | using (force, displacement) $ \(f, d) -> do 52 | Force f' <- f 53 | Displacement d' <- d 54 | 55 | pure (Energy (f' * d')) 56 | 57 | where 58 | -- We're also going to need a function that allows us to take something 59 | -- from this collection and add it to the DAG. Here, we get some help from 60 | -- the 'persist' function. 61 | 62 | fetch 63 | :: forall x f m xs 64 | . (Monad m, x `In` xs ~ False, x `PluckedFrom` Input) 65 | => DaglessT' m xs (x ': xs) (Witness x) 66 | 67 | fetch 68 | = persist (pure (pluck @x collection)) 69 | --------------------------------------------------------------------------------