diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for tangle +## 0.1 + +* Supported higher-kinded result + ## 0 -- 2020-02-09 * First version. Released on an unsuspecting world. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,116 @@ +tangle +---- + +This package implements an abstraction of record construction where each field may depend on other fields. +It is a reimplementation of [extensible's Tangle](https://hackage.haskell.org/package/extensible-0.8.3/docs/Data-Extensible-Tangle.html) refined for more general HKDs. + +```haskell +evalTangleT :: Tangle t m a -- ^ computation + -> t (Tangle t m) -- ^ collection of tangles + -> m a + +hitch + :: Monad m + => (forall h. Lens' (t h) (h a)) -- ^ the lens of the field + -> Tangle t m a +``` + +A computation tangle is a higher-kinded record of `Tangle t`. Each field may fetch other fields by using `hitch`; the result is memoised so the computation is performed at most once for each field. Recursive `hitch` is not supported (becomes an infinite loop). + +`examples/weight.hs` demonstrates a simple program that calculates a body mass index. + +First, we define a highed-kinded record of parameters. +```haskell +data Info h = Info + { _height :: h Double + , _mass :: h Double + , _bmi :: h Double + , _isHealthy :: h Bool + } deriving Generic +instance FunctorB Info +instance ApplicativeB Info +makeLenses ''Info +``` + +Then describe how to compute each field as a record of `TangleT`s. +Note the `_bmi` field fetching `height` and `mass`. + +```haskell +buildInfo :: Info (TangleT Info IO) +buildInfo = Info + { _height = liftIO $ prompt "Height(m): " + , _mass = liftIO $ prompt "Mass(kg): " + , _bmi = do + h <- hitch height + m <- hitch mass + return $! m / (h * h) + , _isHealthy = do + x <- hitch bmi + pure $ x >= 18 && x < 22 + } +``` + +Finally, we can run a computation `go` with `evalTangleT`. +Behold, it asks for height and mass only once, even though the `bmi` field is used twice (via `isHealthy`). + +```haskell +main :: IO () +main = evalTangleT go buildInfo >>= print where + go = (,) <$> hitch bmi <*> hitch isHealthy +``` + +What are tangles? +---- + +Tangle is a __memoisation__ monad for __heterogenous collections__ such as records. +If the collection were just a homogenous container, it is equivalent to + +```haskell +type Key = String +type Container = Map.Map Key + +newtype Tangle b a = Tangle { unTangle :: ReaderT (Container (Tangle b b)) (State (Container b)) a } + deriving (Functor, Applicative, Monad) +``` + +where `Container (Tangle b)` is a collection of computations which would yield the final results, +and `Container b` is the cache of intermediate results. + +With these in mind, the following function can be defined: + +```haskell +hitch :: Key -> Tangle b b +hitch key = Tangle $ ReaderT $ \env -> state $ \cache -> case Map.lookup key cache of + -- If the requested key exists in the cache, just return the value + Just a -> (a, cache) + Nothing -> case Map.lookup key env of + Nothing -> error "Not found" + Just m -> + -- Compute the result + let (result, cache') = unTangle m `runReaderT` env `runState` cache + -- Insert the result to the cache + in (result, Map.insert key result cache') +``` + +Each computation in `Container (Tangle b b)` may `hitch` a value from other keys. +Since `hitch` caches its result, subsequent calls just return the same value; +that's how `Tangle` makes dependent computation composable. + +In `Control.Monad.Tangle`, the container type is generalised to any higher-kinded datatypes. +HKD allows the container type to be in two forms: `t (Tangle t)` (collection of computations) and `t Maybe` (cache of results). +Not just it's much more flexible, the `ApplicativeB` constaint also ensures that the collection and the cache have the same shape. + +Application +---- + +Tangles can split dependent computations into smaller pieces of code without explicity passing values by function arguments. +It implies that it's trivial to add/remove dependencies between computation, because they are automatically handled in the memoisation mechanism. +One useful property is that the cache can be reused as the second argument of `runTangleFT`. +If some fields are expensive to calculate and the rest is expensive to serialise, +the server application could compute the former, distribute the cache, and then let the clients fill the rest. + +See also +---- + +* [Tangle: the dynamic programming monad](https://discourse.haskell.org/t/tangle-the-dynamic-programming-monad/2406) +* [拡張可能タングルでDo記法レスプログラミング♪ (Haskell)](https://matsubara0507.github.io/posts/2018-02-22-fun-of-extensible-3.html) diff --git a/examples/mono.hs b/examples/mono.hs new file mode 100644 --- /dev/null +++ b/examples/mono.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Main where + +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import qualified Data.Map as Map + +type Key = String +type Container = Map.Map Key + +newtype Tangle b a = Tangle { unTangle :: ReaderT (Container (Tangle b b)) (State (Container b)) a } + deriving (Functor, Applicative, Monad) + +hitch :: Key -> Tangle b b +hitch key = Tangle $ ReaderT $ \env -> state $ \cache -> case Map.lookup key cache of + -- If the requested key exists in the cache, just return the value + Just a -> (a, cache) + Nothing -> case Map.lookup key env of + Nothing -> error "Not found" + Just m -> + -- Compute the result + let (result, cache') = unTangle m `runReaderT` env `runState` cache + -- Insert the result to the cache + in (result, Map.insert key result cache') + +evalTangle :: Tangle b a -> Container (Tangle b b) -> a +evalTangle m env = unTangle m `runReaderT` env `evalState` Map.empty + +tangles :: Container (Tangle Int Int) +tangles = Map.fromList + [ ("foo", pure 6) + , ("bar", pure 7) + , ("baz", (*) <$> hitch "foo" <*> hitch "bar") + ] + +main :: IO () +main = print $ evalTangle (hitch "baz") tangles diff --git a/examples/weight.hs b/examples/weight.hs new file mode 100644 --- /dev/null +++ b/examples/weight.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell, DeriveGeneric #-} +module Main where + +import Barbies +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad.Tangle +import GHC.Generics +import System.IO (hFlush, stdout) + +data Info h = Info + { _height :: h Double + , _mass :: h Double + , _bmi :: h Double + , _isHealthy :: h Bool + } deriving Generic +instance FunctorB Info +instance ApplicativeB Info +makeLenses ''Info + +prompt :: Read a => String -> IO a +prompt str = do + putStr str + hFlush stdout + readLn + +buildInfo :: Info (TangleT Info IO) +buildInfo = Info + { _height = liftIO $ prompt "Height(m): " + , _mass = liftIO $ prompt "Mass(kg): " + , _bmi = do + h <- hitch height + m <- hitch mass + return $! m / (h * h) + , _isHealthy = do + x <- hitch bmi + pure $ x >= 18 && x < 22 + } + +main :: IO () +main = evalTangleT go buildInfo >>= print where + go = (,) <$> hitch bmi <*> hitch isHealthy diff --git a/src/Control/Monad/Tangle.hs b/src/Control/Monad/Tangle.hs --- a/src/Control/Monad/Tangle.hs +++ b/src/Control/Monad/Tangle.hs @@ -1,44 +1,106 @@ -{-# LANGUAGE RankNTypes, LambdaCase, GeneralizedNewtypeDeriving, DeriveFunctor, BangPatterns #-} -module Control.Monad.Tangle (TangleT(..), hitch, evalTangleT) where +{-# LANGUAGE RankNTypes, LambdaCase, DeriveFunctor, BangPatterns #-} +module Control.Monad.Tangle + (TangleFT(..), hitchF + , evalTangleFT + , liftTangles + , blank + , hitch + , gather + , TangleF + , evalTangleF + , TangleT + , evalTangleT + , Tangle + , evalTangle + ) where +import Barbies import Control.Applicative import Control.Monad.Trans.Class import Control.Monad.IO.Class import Data.Functor.Identity +import Data.Functor.Compose -newtype TangleT t m a = TangleT - { runTangleT :: t (TangleT t m) -> t Maybe -> m (t Maybe, a) } +-- | 'TangleFT' is a higher-kinded heterogeneous memoisation monad transformer. +-- @t@ represents the shape of the underlying data structure, and @f@ is the wrapper type of each field. +-- This monad represents computations that depend on the contents of @t f@. +newtype TangleFT t f m a = TangleFT + { runTangleFT :: t (Compose (TangleFT t f m) f) + -> t (Compose Maybe f) + -> m (t (Compose Maybe f), a) } deriving Functor -instance Monad m => Applicative (TangleT t m) where - pure a = TangleT $ \_ mem -> pure (mem, a) - TangleT m <*> TangleT n = TangleT $ \ts mem -> m ts mem +instance Monad m => Applicative (TangleFT t f m) where + pure a = TangleFT $ \_ mem -> pure (mem, a) + TangleFT m <*> TangleFT n = TangleFT $ \ts mem -> m ts mem >>= \(mem', f) -> (\(mem'', a) -> (mem'', f a)) <$> n ts mem' -instance Monad m => Monad (TangleT t m) where - TangleT m >>= k = TangleT $ \ts mem -> m ts mem >>= \(mem', a) -> runTangleT (k a) ts mem' +instance Monad m => Monad (TangleFT t f m) where + TangleFT m >>= k = TangleFT $ \ts mem -> m ts mem >>= \(mem', a) -> runTangleFT (k a) ts mem' -instance (Monad m, Semigroup a) => Semigroup (TangleT t m a) where +instance (Monad m, Semigroup a) => Semigroup (TangleFT t f m a) where (<>) = liftA2 (<>) -instance (Monad m, Monoid a) => Monoid (TangleT t m a) where - mempty = pure mempty +instance (Monad m, Monoid a) => Monoid (TangleFT t f m a) where + mempty = pure mempty -instance MonadTrans (TangleT t) where - lift m = TangleT $ \_ mem -> fmap ((,) mem) m +instance MonadTrans (TangleFT t f) where + lift m = TangleFT $ \_ mem -> fmap ((,) mem) m -instance MonadIO m => MonadIO (TangleT t m) where - liftIO m = TangleT $ \_ mem -> fmap ((,) mem) (liftIO m) +instance MonadIO m => MonadIO (TangleFT t f m) where + liftIO m = TangleFT $ \_ mem -> fmap ((,) mem) (liftIO m) +-- | Collect all results in the tangle. +gather :: (TraversableB t, Monad m) => TangleFT t f m (t f) +gather = TangleFT $ \env prev -> runTangleFT (btraverse getCompose env) env prev + +-- | Obtain a value from the tangle. The result gets memoised. +hitchF :: Monad m + => (forall h g. Functor g => (h a -> g (h a)) -> t h -> g (t h)) -- ^ van Laarhoven lens + -> TangleFT t f m (f a) +hitchF l = TangleFT $ \ts mem -> getConst $ flip l mem $ \case + Compose (Just a) -> Const $ pure (mem, a) + Compose Nothing -> Const + $ fmap (\(mem', a) -> let !(Identity mem'') = l (const $ pure $ Compose $ Just a) mem' in (mem'', a)) + $ runTangleFT (getCompose $ getConst $ l Const ts) ts mem +{-# INLINE hitchF #-} + +evalTangleFT :: (ApplicativeB t, Functor m) => TangleFT t f m a -> t (Compose (TangleFT t f m) f) -> m a +evalTangleFT m t = snd <$> runTangleFT m t blank +{-# INLINE evalTangleFT #-} + +-- | Lift a collection of 'TangleT's so that it fits the argument of 'runTangleFT'. +liftTangles :: (FunctorB b, Functor m) => b (TangleT b m) -> b (Compose (TangleT b m) Identity) +liftTangles = bmap (Compose . fmap Identity) +{-# INLINE liftTangles #-} + +-- | A product where all the elements are 'Compose' 'Nothing' +blank :: ApplicativeB b => b (Compose Maybe f) +blank = bpure $ Compose Nothing + +-- | Bare version of 'TangleFT' +type TangleT t = TangleFT t Identity + +-- | Non-transformer version of 'TangleFT' +type TangleF t f = TangleFT t f Identity + +-- | Bare non-transformer tangle +type Tangle t = TangleFT t Identity Identity + +-- | Bare variant of 'hitchF' hitch :: Monad m - => (forall h f. Functor f => (h a -> f (h a)) -> t h -> f (t h)) + => (forall h g. Functor g => (h a -> g (h a)) -> t h -> g (t h)) -- ^ van Laarhoven lens -> TangleT t m a -hitch l = TangleT $ \ts mem -> getConst $ flip l mem $ \case - Just a -> Const $ pure (mem, a) - Nothing -> Const - $ fmap (\(mem', a) -> let !(Identity mem'') = l (const $ pure $ Just a) mem' in (mem'', a)) - $ runTangleT (getConst $ l Const ts) ts mem +hitch l = runIdentity <$> hitchF l {-# INLINE hitch #-} -evalTangleT :: Functor m => TangleT t m a -> t (TangleT t m) -> t Maybe -> m a -evalTangleT m t s = snd <$> runTangleT m t s +evalTangleF :: ApplicativeB t => TangleF t f a -> t (Compose (TangleF t f) f) -> a +evalTangleF m t = snd $ runIdentity $ runTangleFT m t blank +{-# INLINE evalTangleF #-} + +evalTangleT :: (Functor m, ApplicativeB t) => TangleT t m a -> t (TangleT t m) -> m a +evalTangleT m t = fmap snd $ runTangleFT m (liftTangles t) blank {-# INLINE evalTangleT #-} + +evalTangle :: (ApplicativeB t) => Tangle t a -> t (Tangle t) -> a +evalTangle m t = runIdentity $ evalTangleT m t +{-# INLINE evalTangle #-} diff --git a/tangle.cabal b/tangle.cabal --- a/tangle.cabal +++ b/tangle.cabal @@ -1,20 +1,17 @@ cabal-version: 2.4 --- Initial package description 'tangle.cabal' generated by 'cabal init'. --- For further documentation, see http://haskell.org/cabal/users-guide/ - name: tangle -version: 0 -synopsis: HKD record builder +version: 0.1 +synopsis: Heterogenous memoisation monad description: See README.md for details bug-reports: https://github.com/fumieval/tangle/issues license: BSD-3-Clause license-file: LICENSE author: Fumiaki Kinoshita maintainer: fumiexcel@gmail.com -copyright: Copyright(c) 2020 Fumiaki Kinoshita -category: Monad -extra-source-files: CHANGELOG.md -tested-with: GHC == 8.8.1, ghc == 8.6.5 +copyright: Copyright(c) 2021 Fumiaki Kinoshita +category: Monad, Data Structures +extra-source-files: CHANGELOG.md, README.md +tested-with: GHC == 9.0.1, GHC == 8.10.7 source-repository head type: git @@ -24,7 +21,21 @@ exposed-modules: Control.Monad.Tangle -- other-modules: -- other-extensions: - build-depends: base >= 4.12 && <5, transformers + build-depends: base >= 4.12 && <5, transformers, barbies hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -Wcompat + +executable weight + hs-source-dirs: examples + default-language: Haskell2010 + ghc-options: -Wall -Wcompat + build-depends: base >= 4.12 && <5, transformers, barbies, lens, tangle + main-is: weight.hs + +executable mono + hs-source-dirs: examples + default-language: Haskell2010 + ghc-options: -Wall -Wcompat + build-depends: base >= 4.12 && <5, transformers, containers + main-is: mono.hs