diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +Changelog +========= + +Version 0.1.0.0 +--------------- + +*January 23, 2020* + + + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Justin Le (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Justin Le nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,203 @@ +[mutable][docs] +=============== + +[![mutable on Hackage](https://img.shields.io/hackage/v/mutable.svg?maxAge=86400)](https://hackage.haskell.org/package/mutable) +[![Build Status](https://travis-ci.org/mstksg/mutable.svg?branch=master)](https://travis-ci.org/mstksg/mutable) + +[**Documentation and Walkthrough**][docs] + +[docs]: https://mutable.jle.im + +Beautiful Mutable Values +------------------------ + +**Mutability can be awesome!** + +Take back the power of **mutable objects** with all the **safety** and explicit +state of Haskell. Associate and generate "piecewise-mutable" versions for your +composite data types in a composable and automatic way. Think of it like a +"generalized `MVector` for all ADTs". It also leverages GHC Generics to make +working with piecewise mutability as simple as possible. + +Making piecewise updates on your giant composite data types (like artificial +neural networks or game states in your game loop) got you down because they +require re-allocating the entire value? Tired of requiring a full deep copy +every time you make a small change, and want to be able to build mutable +versions of your types automatically in composable ways? This is the package +for you. + +Useful for a situation where you have a record with many fields (or many nested +records) that you want to use for efficient mutable in-place algorithms. This +library lets you do efficient "piecewise" mutations (operations that only edit +one field), and also efficient entire-datatype copies/updates, as well, in many +cases. + +Check out the [documentation home page][docs], [haddock reference][haddock], or +read below for motivation and high-level descriptions. + +[haddock]: https://hackage.haskell.org/package/mutable + +Motivation +---------- + +### Piecewise-Mutable + +For a simple motivating example where in-place piecewise mutations might be +better, consider a large vector. + +Let's say you only want to edit the first item in a vector, multiple times. +This is extremely inefficient with a pure vector: + +```haskell +addFirst :: Vector Double -> Vector Double +addFirst xs = iterate incr xs !! 1000000 + where + incr v = v V.// [(0, (v V.! 0) + 1)] +``` + +That's because `addFirst` will copy over the entire vector for every step +--- every single item, even if not modified, will be copied one million times. +It is `O(n*l)` in memory updates --- it is very bad for long vectors or large +matrices. + +However, this is extremely efficient with a mutable vector: + +```haskell +addFirst :: Vector Double -> Vector Double +addFirst xs = runST $ do + v <- V.thaw xs + replicateM_ 1000000 $ do + MV.modify v 0 (+ 1) + V.freeze v +``` + +This is because all of the other items in the vector are kept the same and not +copied-over over the course of one million updates. It is `O(n+l)` in memory +updates. It is very good even for long vectors or large matrices. + +(Of course, this situation is somewhat contrived, but it isolates a problem that +many programs face. A more common situation might be that you have two +functions that each modify different items in a vector in sequence, and you +want to run them many times interleaved, or one after the other.) + +Composite Datatype +------------------ + +That all works for `MVector`, but let's say you have a simple composite data +type that is two vectors: + +```haskell +data TwoVec = TV { tv1 :: Vector Double + , tv2 :: Vector Double + } + deriving Generic +``` + +Is there a nice "piecewise-mutable" version of this? You *could* break up +`TwoVec` manually into its pieces and treat each piece independently, but that method +isn't composable. If only there was some equivalent of `MVector` for +`TwoVec`...and some equivalent of `MV.modify`. + +That's where this library comes in. + +```haskell +instance PrimMonad m => Mutable m TwoVec where + type Ref m TwoVec = GRef m TwoVec +``` + +This gives us `thawRef :: TwoVec -> m (GRef m TwoVec)`, where `GRef m TwoVec` +is a mutable version of `TwoVec`, like how `MVector s Double` is a mutable +version of `Vector Double`. It stores each field `tv1` and `tv2` as a seaprate +`MVector` in memory that can be modified independently. + +Now we can write: + +```haskell +addFirst :: TwoVec -> TwoVec +addFirst xs = runST $ do + v <- thawRef xs + replicateM_ 1000000 $ do + withField #tv1 v $ \u -> + MV.modify u 0 (+ 1) + freezeRef v +``` + +This will in-place edit only the first item in the `tv1` field one million +times, without ever needing to copy over the contents `tv2`. Basically, it +gives you a version of `TwoVec` that you can modify in-place piecewise. You +can compose two functions that each work piecewise on `TwoVec`: + +```haskell +mut1 :: PrimMonad m => Ref m TwoVec -> m () +mut1 v = do + withField #tv1 v $ \u -> + MV.modify u 0 (+ 1) + MV.modify u 1 (+ 2) + withField #tv2 v $ \u -> + MV.modify u 2 (+ 3) + MV.modify u 3 (+ 4) + +mut2 :: PrimMonad m => Ref m TwoVec -> m () +mut2 v = do + withField #tv1 v $ \u -> + MV.modify u 4 (+ 1) + MV.modify u 5 (+ 2) + withField #tv2 v $ \u -> + MV.modify u 6 (+ 3) + MV.modify u 7 (+ 4) + +doAMillion :: TwoVec -> TwoVec +doAMillion xs = runST $ do + v <- thawRef xs + replicateM_ 1000000 $ do + mut1 v + mut2 v + freezeRef v +``` + +This is a type of composition and interleaving that cannot be achieved by +simply breaking down `TwoVec` and running functions that work purely on each of +the two vectors individually. + +Show me the numbers +------------------- + +Here are some benchmark cases --- only bars of the same color are comparable, +and shorter bars are better (performance-wise). + +![Benchmarks](https://i.imgur.com/S95TuiM.png) + +There are four situations here, compared and contrasted between pure and +mutable versions + +1. A large ADT with 256 fields, generated by repeated nestings of `data V4 a = + V4 !a !a !a !a` + + 1. Updating only a single part (one field out of 256) + 2. Updating the entire ADT (all 256 fields) + +2. A composite data type of four `Vector`s of 500k elements each, so 2 million + elements total. + + 1. Updating only a single part (one item out of 2 million) + 2. Updating all elements of all four vectors (all 2 million items) + +We can see four conclusions: + +1. For a large ADT, updating a single field (or multiple fields, interleaved) + is going to be faster with *mutable*. This speedup is between x4 and x5, + suggesting it is a speedup arising from the fact that the top-level type + has four fields. +2. For a large ADT, updating the whole ADT (so just replacing the entire + thing, no actual copies) is faster just as a pure value by a large factor + (which is a big testament to GHC). +3. For a small ADT with huge vectors, updating a single field is *much* faster + with *mutable*. +4. For a small ADT with huge vectors, updating the entire value (so, the + entire vectors and entire ADT) is actually faster with *mutable* as well. + +Interestingly, the "update entire structure" case (which should be the +worst-case for *mutable* and the best-case for pure values) actually becomes +faster with *mutable* when you get to the region of *many* values... somewhere +between 256 and 2 million, apparently. However, this may just be from the +efficiency of modifying vectors sequentially. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +import Control.Category ((.)) +import Control.DeepSeq +import Control.Monad.ST +import Control.Monad.Trans.Class +import Control.Monad.Trans.Cont +import Control.Monad.Trans.State +import Criterion.Main +import Criterion.Types +import Data.Foldable +import Data.Mutable +import Data.Time +import Data.Vector (Vector) +import Data.Vinyl.Functor +import GHC.Generics +import Lens.Micro +import Lens.Micro.TH +import Prelude hiding ((.)) +import System.Directory +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV + +data V4 a = V4 { _v4X :: !a + , _v4Y :: !a + , _v4Z :: !a + , _v4W :: !a + } + deriving (Show, Generic, Functor, Foldable, Traversable) + +instance NFData a => NFData (V4 a) +instance Mutable m a => Mutable m (V4 a) where + type Ref m (V4 a) = GRef m (V4 a) +instance Applicative V4 where + pure x = V4 x x x x + V4 a b c d <*> V4 x y z w = V4 (a x) (b y) (c z) (d w) +makeLenses 'V4 + +newtype V256 a = V256 { _v256 :: V4 (V4 (V4 (V4 a))) } + deriving (Show, Generic, Functor, Foldable, Traversable) + deriving Applicative via (V4 :.: V4 :.: V4 :.: V4) +instance NFData a => NFData (V256 a) +instance Mutable m a => Mutable m (V256 a) where + type Ref m (V256 a) = CoerceRef m (V256 a) (V4 (V4 (V4 (V4 a)))) +makeLenses 'V256 + +-- HKD variant of V4 +data V4F a f = V4F { _vf4X :: !(f a) + , _vf4Y :: !(f a) + , _vf4Z :: !(f a) + , _vf4W :: !(f a) + } + deriving (Show, Generic) +instance NFData (f a) => NFData (V4F a f) +instance Mutable m a => Mutable m (V4F a Identity) where + type Ref m (V4F a Identity) = V4F a (RefFor m) + +-- HKD variant of V256 +newtype V256F a = V256F { _v256F :: V4F (V4F (V4F (V4F a Identity) Identity) Identity) Identity } + deriving (Show, Generic) +instance NFData a => NFData (Identity a) +instance NFData a => NFData (V256F a) +instance Mutable m a => Mutable m (V256F a) where + type Ref m (V256F a) = CoerceRef m (V256F a) (V4F (V4F (V4F (V4F a Identity) Identity) Identity) Identity) + + +type ADT = V256 Double +type ADTF = V256F Double +type Vec = V4 (Vector Double) +type VecF = V4F (Vector Double) Identity + +pureLoop :: (a -> a) -> Int -> a -> a +pureLoop f n = go 0 + where + go !i !x + | i < n = go (i + 1) (f x) + | otherwise = x + +modifyPartPure :: Int -> ADT -> ADT +modifyPartPure = pureLoop $ over (v256 . v4X . v4X . v4X . v4X) (+1) + +modifyWholePure :: Int -> ADT -> ADT +modifyWholePure = pureLoop $ fmap (+ 1) + +modifyPartPureV :: Int -> Vec -> Vec +modifyPartPureV = pureLoop $ over v4X $ \v -> v V.// [(0, (v V.! 0) + 1)] + +modifyWholePureV :: Int -> Vec -> Vec +modifyWholePureV = pureLoop $ (fmap . fmap) (+ 1) + + + + +mutLoop :: (forall s. Mutable (ST s) a) => (forall s. Ref (ST s) a -> ST s ()) -> Int -> a -> a +mutLoop f n x0 = runST $ do + r <- thawRef x0 + let go !i + | i < n = do + f r + go (i + 1) + | otherwise = pure () + go 0 + unsafeFreezeRef r + +modifyPartMut :: (forall s. Mutable (ST s) a) => (forall s. MutPart (ST s) a Double) -> Int -> a -> a +modifyPartMut f = mutLoop $ \r -> modifyPart' f r (+1) + +modifyWholeMut :: (forall s b. Mutable (ST s) b => Ref (ST s) (V4 b) -> ContT () (ST s) (Ref (ST s) b)) -> Int -> ADT -> ADT +modifyWholeMut f = mutLoop $ \r -> + withAllRefV256 f r $ \s -> + modifyRef s (+ 1) + +modifyWholeMutHKD :: Int -> ADTF -> ADTF +modifyWholeMutHKD = mutLoop $ \r -> + withAllRefV256HKD r $ \s -> + modifyRef s (+ 1) + +modifyPartMutV :: (forall s. Mutable (ST s) a) => (forall s. MutPart (ST s) a (Vector Double)) -> Int -> a -> a +modifyPartMutV f = mutLoop $ \r -> withPart f r $ \mv -> + (MV.write mv 0 $!) . (+ 1) =<< MV.read mv 0 + +modifyWholeMutV :: (forall s. Mutable (ST s) a) => (forall s. Ref (ST s) a -> ContT () (ST s) (MV.MVector s Double)) -> Int -> a -> a +modifyWholeMutV f = mutLoop $ \r -> runContT (f r) $ \mv -> do + forM_ [0 .. MV.length mv - 1] $ \i -> + (MV.write mv i $!) . (+ 1) =<< MV.read mv i + +main :: IO () +main = do + t <- getZonedTime + let tstr = formatTime defaultTimeLocale "%Y%m%d-%H%M%S" t + createDirectoryIfMissing True "bench-results" + defaultMainWith defaultConfig + { reportFile = Just $ "bench-results/mutable-bench_" ++ tstr ++ ".html" + , timeLimit = 10 + } [ + bgroup "adt-256" [ + bgroup "part-50M" + [ bench "pure" $ nf (modifyPartPure 50_000_000) bigADT + -- , bench "mutable" $ nf (modifyPartMut (partRep (fieldMut #_v4X)) 50_000_000) bigADT + , bgroup "mutable" [ + bench "field" $ nf (modifyPartMut (partRep (fieldMut #_v4X)) 50_000_000) bigADT + , bench "pos" $ nf (modifyPartMut (partRep (posMut @1 )) 50_000_000) bigADT + , bench "tuple" $ nf (modifyPartMut (partRep firstTuple ) 50_000_000) bigADT + , bench "hkd" $ nf (modifyPartMut modPartHKD 50_000_000) bigADTF + ] + ] + , bgroup "whole-20K" + [ bench "pure" $ nf (modifyWholePure 20_000) bigADT + -- , bench "mutable" $ nf (modifyWholeMut withAllRefV4Field 20_000) bigADT + , bgroup "mutable" [ + bench "field" $ nf (modifyWholeMut withAllRefV4Field 20_000) bigADT + , bench "pos" $ nf (modifyWholeMut withAllRefV4Pos 20_000) bigADT + , bench "tuple" $ nf (modifyWholeMut withAllRefV4Tuple 20_000) bigADT + , bench "hkd" $ nf (modifyWholeMutHKD 20_000) bigADTF + ] + ] + ] + , bgroup "vector-2M" [ + bgroup "part-100" + [ bench "pure" $ nf (modifyPartPureV 100) bigVec + -- , bench "mutable" $ nf (modifyPartMutV (fieldMut #_v4X) 100) bigVec + , bgroup "mutable" [ + bench "field" $ nf (modifyPartMutV (fieldMut #_v4X) 100) bigVec + , bench "pos" $ nf (modifyPartMutV (posMut @1 ) 100) bigVec + , bench "tuple" $ nf (modifyPartMutV (firstTuple ) 100) bigVec + , bench "hkd" $ nf (modifyPartMutV (_vf4X vfParts) 100) bigVecF + ] + ] + , bgroup "whole-3" + [ bench "pure" $ nf (modifyWholePureV 3) bigVec + -- , bench "mutable" $ nf (modifyWholeMutV withAllRefV4Field 3) bigVec + , bgroup "mutable" [ + bench "field" $ nf (modifyWholeMutV withAllRefV4Field 3) bigVec + , bench "pos" $ nf (modifyWholeMutV withAllRefV4Pos 3) bigVec + , bench "tuple" $ nf (modifyWholeMutV withAllRefV4Tuple 3) bigVec + , bench "hkd" $ nf (modifyWholeMutV withAllRefV4HKD 3) bigVecF + ] + ] + ] + ] + where + bigADT :: ADT + !bigADT = populate $ pure () + bigADTF :: ADTF + !bigADTF = toADTF bigADT + bigVec :: Vec + !bigVec = getCompose . populate . Compose $ pure (V.replicate 500_000 ()) + bigVecF :: VecF + !bigVecF = toVF bigVec + + + +toADTF :: ADT -> ADTF +toADTF = V256F + . toVF . fmap (toVF . fmap (toVF . fmap toVF)) + . _v256 + +toVF :: V4 a -> V4F a Identity +toVF (V4 a b c d) = V4F (Identity a) (Identity b) (Identity c) (Identity d) + +vfParts :: forall m a. Mutable m a => V4F a (MutPart m (V4F a Identity)) +vfParts = hkdMutParts @(V4F a) + +partRep :: Mutable m a => (forall b. Mutable m b => MutPart m (V4 b) b) -> MutPart m (V256 a) a +partRep f = f . f . f . f . coerceRef + +firstTuple :: Mutable m a => MutPart m (V4 a) a +firstTuple = MutPart (\(x,_,_,_) -> x) . tupleMut + +modPartHKD :: forall m a. Mutable m a => MutPart m (V256F a) a +modPartHKD = _vf4X vfParts + . _vf4X vfParts + . _vf4X vfParts + . _vf4X vfParts + . coerceRef + + + +withAllRefV4Field :: Mutable m a => Ref m (V4 a) -> ContT () m (Ref m a) +withAllRefV4Field r = ContT $ \f -> do + withPart (fieldMut #_v4X) r f + withPart (fieldMut #_v4Y) r f + withPart (fieldMut #_v4Z) r f + withPart (fieldMut #_v4W) r f + +withAllRefV4Pos :: Mutable m a => Ref m (V4 a) -> ContT () m (Ref m a) +withAllRefV4Pos r = ContT $ \f -> do + withPart (posMut @1) r f + withPart (posMut @2) r f + withPart (posMut @3) r f + withPart (posMut @4) r f + +withAllRefV4Tuple :: Mutable m a => Ref m (V4 a) -> ContT () m (Ref m a) +withAllRefV4Tuple r = ContT $ \f -> + withTuple r $ \(x, y, z, w) -> do + f x + f y + f z + f w + +withAllRefV4HKD :: forall m a. Mutable m a => V4F a (RefFor m) -> ContT () m (Ref m a) +withAllRefV4HKD r = ContT $ \f -> do + withPart (_vf4X vfParts) r f + withPart (_vf4Y vfParts) r f + withPart (_vf4Z vfParts) r f + withPart (_vf4W vfParts) r f + +withAllRefV256 + :: Mutable m a + => (forall b. Mutable m b => Ref m (V4 b) -> ContT () m (Ref m b)) + -> Ref m (V256 a) + -> (Ref m a -> m ()) + -> m () +withAllRefV256 a r f = flip runContT pure $ do + s <- a =<< a =<< a =<< a + =<< ContT (withPart coerceRef r) + lift $ f s + + +withAllRefV256HKD :: Mutable m a => Ref m (V256F a) -> (Ref m a -> m ()) -> m () +withAllRefV256HKD r f = flip runContT pure $ do + s <- withAllRefV4HKD + =<< withAllRefV4HKD + =<< withAllRefV4HKD + =<< withAllRefV4HKD + =<< ContT (withPart coerceRef r) + lift $ f s + +populate :: Traversable f => f () -> f Double +populate = flip evalState 0 . traverse go + where + go _ = state $ \i -> (fromInteger i, i + 1) + diff --git a/mutable.cabal b/mutable.cabal new file mode 100644 --- /dev/null +++ b/mutable.cabal @@ -0,0 +1,84 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 4bc371a3f5a9dc170b74be324280aeabe3d89a2be7c8766d3b5c3e27b5b29333 + +name: mutable +version: 0.1.0.0 +synopsis: Automatic piecewise-mutable references for your types +description: Associate and generate "piecewise-mutable" versions for your composite data + types. Think of it like a "generalized MVector for all ADTs". + . + Useful for a situation where you have a record with many fields (or many nested + records) that you want to use for efficient mutable in-place algorithms. This + library lets you do efficient "piecewise" mutations (operations that only edit + one field), and also efficient entire-datatype copies/updates, as well, in many + cases. + . + See for official introduction and documentation, + or jump right in by importing "Data.Mutable". +category: Data +homepage: https://github.com/mstksg/mutable#readme +bug-reports: https://github.com/mstksg/mutable/issues +author: Justin Le +maintainer: justin@jle.im +copyright: (c) Justin Le 2020 +license: BSD3 +license-file: LICENSE +tested-with: GHC >= 8.6 && < 8.10 +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/mstksg/mutable + +library + exposed-modules: + Data.Mutable + Data.Mutable.Branches + Data.Mutable.Class + Data.Mutable.Instances + Data.Mutable.Parts + other-modules: + Data.Mutable.Internal + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Wredundant-constraints -Werror=incomplete-patterns + build-depends: + base >=4.11 && <5 + , constraints + , generic-lens >=1.1 + , primitive >=0.6.4 + , reflection + , transformers + , vector + , vinyl + default-language: Haskell2010 + +benchmark mutable-bench + type: exitcode-stdio-1.0 + main-is: bench.hs + other-modules: + Paths_mutable + hs-source-dirs: + bench + ghc-options: -Wall -Wcompat -Wredundant-constraints -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N -O2 + build-depends: + base >=4.12 && <5 + , criterion + , deepseq + , directory + , microlens + , microlens-th + , mutable + , time + , transformers + , vector + , vinyl + default-language: Haskell2010 diff --git a/src/Data/Mutable.hs b/src/Data/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mutable.hs @@ -0,0 +1,84 @@ + +-- | +-- Module : Data.Mutable.Class +-- Copyright : (c) Justin Le 2020 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Main entrypoint of the package. Abstract over different types for +-- piecewise-mutable references of values. +-- +-- See for a comprehensive introduction. +module Data.Mutable ( + Mutable(..) + , modifyRef, modifyRef' + , updateRef, updateRef' + , RefFor(..) + -- * Instances + , DefaultMutable + , GRef + , MutVar + , CoerceRef(..) + , TraverseRef(..) + , GMutableRef(..) + , HListRef(..) + -- * Providing/overriding instances + , VarMut(..) + , CoerceMut(..) + , TraverseMut(..) + , Immutable(..) + -- * Parts + , MutPart(..) + , withPart + , freezePart, copyPart + , movePartInto, movePartOver, movePartWithin + , clonePart, unsafeFreezePart + , modifyPart, modifyPart' + , updatePart, updatePart' + -- ** Built-in 'MutPart' + -- *** Field + , FieldMut(..), withField, mutField, Label(..) + -- *** Position + , PosMut(..), withPos, mutPos + -- *** Tuple + , TupleMut(..), withTuple + -- *** Higher-Kinded Data + , hkdMutParts, HKDMutParts + -- *** Other + , mutFst, mutSnd + , mutRec + , coerceRef, withCoerceRef + -- * Branches + , MutBranch(..) + , thawBranch + , freezeBranch + , moveBranch + , copyBranch + , cloneBranch + , hasBranch, hasn'tBranch + , unsafeThawBranch + , unsafeFreezeBranch + , withBranch, withBranch_ + , modifyBranch, modifyBranch' + , updateBranch, updateBranch' + -- ** Built-in 'MutBranch' + -- *** Using GHC Generics + , constrMB, CLabel(..), GMutBranchConstructor, MapRef + -- *** For common types + , nilMB, consMB + , nothingMB, justMB + , leftMB, rightMB + -- * Re-exports + , PrimMonad, PrimState + ) where + +import Control.Monad.Primitive +import Data.Mutable.Branches +import Data.Mutable.Class +import Data.Mutable.Instances +import Data.Mutable.Parts +import Data.Primitive.MutVar + diff --git a/src/Data/Mutable/Branches.hs b/src/Data/Mutable/Branches.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mutable/Branches.hs @@ -0,0 +1,681 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + + +-- | +-- Module : Data.Mutable.MutBranch +-- Copyright : (c) Justin Le 2020 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Tools for working with potential branches of piecewise-mutable +-- values. +-- +-- If "Data.Mutable.Parts" is for product types, then +-- "Data.Mutable.Branches" is for sum types. +-- +-- See for an +-- introduction to this module. +module Data.Mutable.Branches ( + MutBranch(..) + , thawBranch + , freezeBranch + , hasBranch, hasn'tBranch + , moveBranch + , copyBranch + , cloneBranch + , unsafeThawBranch + , unsafeFreezeBranch + , withBranch, withBranch_ + , modifyBranch, modifyBranch' + , updateBranch, updateBranch' + , modifyBranchM, modifyBranchM' + , updateBranchM, updateBranchM' + -- * Built-in 'MutBranch' + , compMB, idMB + -- ** Using GHC Generics + , constrMB, CLabel(..), GMutBranchConstructor, MapRef + -- ** For common types + , nilMB, consMB + , nothingMB, justMB + , leftMB, rightMB + ) where + +import Control.Monad +import Control.Monad.Primitive +import Data.Maybe +import Data.Mutable.Class +import Data.Mutable.Instances +import Data.Primitive.MutVar +import GHC.Generics +import GHC.OverloadedLabels +import GHC.TypeLits +import qualified Data.GenericLens.Internal as GL +import qualified Data.Generics.Internal.Profunctor.Lens as GLP + +-- | A @'MutBranch' m s a@ represents the information that @s@ could +-- potentially be an @a@. Similar in spirit to a @Prism' s a@. +-- +-- @'MutBranch' m s a@ means that @a@ is one potential option that @s@ +-- could be in, or that @s@ is a sum type and @a@ is one of the +-- branches/constructors. +-- +-- See for an +-- introduction to this module. +-- +-- If 'Data.Mutable.Parts.MutPart' is for product types, then 'MutBranch' +-- is for sum types. +-- +-- In this case, "branch" means "potential option". For example, the +-- branches of 'Either' are 'Left' and 'Right'. +-- +-- The simplest way to make these is by using 'constrMB'. For instance, to +-- get the two branches of an 'Either': +-- +-- @ +-- constrMB #_Left :: MutBranch m (Either a b) a +-- constrMB #_Right :: MutBranch m (Either a b) b +-- @ +-- +-- @ +-- ghci> r <- 'thawRef' (Left 10) +-- ghci> 'freezeBranch' ('constrMB' #_Left) r +-- Just 10 +-- ghci> freezeBranch (constrMB #_Right) r +-- Nothing +-- @ +-- +-- It uses OverloadedLabels, but requires an underscore before the +-- constructor name due to limitations in the extension. +-- +-- One nice way to /use/ these is with 'withBranch_': +-- +-- @ +-- ghci> r <- 'thawRef' (Just 10) +-- ghci> 'withBranch_' (constrMB #_Just) $ \i -> -- @i@ is an Int ref +-- .. modifyRef i (+ 1) +-- ghci> 'freezeRef' r +-- Just 11 +-- @ +-- +-- @ +-- ghci> r <- thawRef Nothing +-- ghci> withBranch_ (constrMB #_Just) $ \i -> -- @i@ is an Int ref +-- .. modifyRef i (+ 1) +-- ghci> freezeRef r +-- Nothing +-- @ +-- +-- Perhaps the most useful usage of this abstraction is for recursive data +-- types. +-- +-- @ +-- data List a = Nil | Cons a (List a) +-- deriving Generic +-- +-- instance Mutable m a => 'Mutable' m (List a) where +-- type Ref m (List a) = 'GRef' m (List a) +-- @ +-- +-- @'GRef' m (List a)@ is now a mutable linked list! Once we make the +-- 'MutBranch' for the nil and cons cases: +-- +-- @ +-- nilBranch :: MutBranch m (List a) () +-- nilBranch = constrMB #_Nil +-- +-- consBranch :: MutBranch m (List a) (a, List a) +-- consBranch = constrMB #_Cons +-- @ +-- +-- +-- Here is a function to check if a linked list is currently empty: +-- +-- @ +-- isEmpty +-- :: (PrimMonad m, Mutable m a) +-- => Ref m (List a) +-- -> m Bool +-- isEmpty = hasBranch nilBranch +-- @ +-- +-- Here is one to "pop" a mutable linked list, giving us the first value +-- and shifting the rest of the list up. +-- +-- @ +-- popStack +-- :: (PrimMonad m, Mutable m a) +-- => Ref m (List a) +-- -> m (Maybe a) +-- popStack r = do +-- c <- projectBranch consBranch r +-- case c of +-- Nothing -> pure Nothing +-- Just (x, xs) -> do +-- moveRef r xs +-- Just <$> freezeRef x +-- @ +-- +-- And here is a function to concatenate a second linked list to the end of a +-- first one. +-- +-- @ +-- concatLists +-- :: (PrimMonad m, Mutable m a) +-- => Ref m (List a) +-- -> Ref m (List a) +-- -> m () +-- concatLists l1 l2 = do +-- c <- projectBranch consBranch l1 +-- case c of +-- Nothing -> moveRef l1 l2 +-- Just (_, xs) -> concatLists xs l2 +-- @ +data MutBranch m s a = MutBranch + { -- | With a 'MutBranch', attempt to get the mutable contents of + -- a branch of a mutable + -- @s@, if possible. + -- + -- @ + -- ghci> r <- thawRef (Left 10) + -- ghci> s <- cloneBranch (constrMB #_Left) + -- ghci> case s of Just s' -> freezeRef s' + -- 10 + -- @ + -- + -- @ + -- ghci> r <- thawRef (Right True) + -- ghci> s <- cloneBranch (constrMB #_Left) + -- ghci> case s of Nothing -> "it was Right" + -- "it was Right" + -- @ + projectBranch :: Ref m s -> m (Maybe (Ref m a)) + -- | Embed an @a@ ref as a part of a larger @s@ ref. Note that this + -- /does not copy or clone/: any mutations to the @a@ ref will be + -- reflected in the @s@ ref, as long as the @s@ ref maintains the + -- reference. + -- + -- @ + -- ghci> r <- thawRef 100 + -- ghci> s <- embedBranch (constMB #_Left) r + -- ghci> freezeRef s + -- Left 100 + -- ghci> modifyRef r (+ 1) + -- ghci> freezeRef s + -- Left 101 + -- @ + -- + -- Any mutations on @s@ (as long as they keep the same branch) will + -- also affect @a@: + -- + -- @ + -- ghci> copyRef s (Left 0) + -- ghci> freezeRef r + -- 0 + -- @ + -- + -- However, "switching branches" on an 'Either' ref will cause it to + -- loose the original reference: + -- + -- @ + -- ghci> copyRef s (Right True) + -- ghci> copyRef s (Left 999) + -- ghci> freezeRef r + -- 0 + -- @ + , embedBranch :: Ref m a -> m (Ref m s) + } + +-- | Compose two 'MutBranch's, to drill down on what is being focused. +compMB :: Monad m => MutBranch m a b -> MutBranch m b c -> MutBranch m a c +compMB mb1 mb2 = MutBranch + { projectBranch = projectBranch mb1 >=> \case + Nothing -> pure Nothing + Just s -> projectBranch mb2 s + , embedBranch = embedBranch mb1 <=< embedBranch mb2 + } + +-- | An identity 'MutBranch', treating the item itself as a whole branch. +-- 'cloneBranch' will always "match". +idMB :: Applicative m => MutBranch m a a +idMB = MutBranch (pure . Just) pure + +-- | With a 'MutBranch', thaw an @a@ into a mutable @s@ on that branch. +-- +-- @ +-- ghci> r <- 'thawBranch' ('constrMB' #_Left) 10 +-- ghci> 'freezeRef' r +-- Left 10 +-- @ +thawBranch + :: Mutable m a + => MutBranch m s a + -> a + -> m (Ref m s) +thawBranch mb = embedBranch mb <=< thawRef + +-- | With a 'MutBranch', read out a specific @a@ branch of an @s@, if it exists. +-- +-- @ +-- ghci> r <- 'thawRef' (Left 10) +-- ghci> 'freezeBranch' ('constrMB' #_Left) r +-- Just 10 +-- ghci> freezeBranch (constrMB #_Right) r +-- Nothing +-- @ +freezeBranch + :: Mutable m a + => MutBranch m s a -- ^ How to check if is @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of + -> m (Maybe a) +freezeBranch mb = mapM freezeRef <=< projectBranch mb + +-- | Check if an @s@ is currently a certain branch @a@. +hasBranch + :: Mutable m a + => MutBranch m s a + -> Ref m s + -> m Bool +hasBranch mb = fmap isJust . projectBranch mb + +-- | Check if an @s@ is /not/ currently a certain branch @a@. +hasn'tBranch + :: Mutable m a + => MutBranch m s a + -> Ref m s + -> m Bool +hasn'tBranch mb = fmap isNothing . projectBranch mb + +-- | With a 'MutBranch', /set/ @s@ to have the branch @a@. +-- +-- @ +-- ghci> r <- 'thawRef' (Left 10) +-- ghci> 'copyBranch' ('constrMB' #_Left) r 5678 +-- ghci> 'freezeRef' r +-- Left 5678 +-- ghci> copyBranch (constrMB #_Right) r True +-- ghci> freezeRef r +-- Right True +-- @ +copyBranch + :: (Mutable m s, Mutable m a) + => MutBranch m s a -- ^ How to check if @s@ is an @a@ + -> Ref m s -- ^ Structure to write into + -> a -- ^ Value to set @s@ to be + -> m () +copyBranch mb r = moveBranch mb r <=< thawRef + +-- | With a 'MutBranch', overwrite an @s@ as an @a@, on that branch. +-- +-- @ +-- ghci> r <- thawRef (Left 10) +-- ghci> s <- thawRef 100 +-- ghci> moveBranch (constrMB #_Left) r s +-- ghci> freezeRef r +-- Left 100 +-- ghci> t <- thawRef True +-- ghci> moveBranch (constrMB #_Right) r t +-- ghci> freezeRef r +-- Right True +-- @ +moveBranch + :: Mutable m s + => MutBranch m s a + -> Ref m s + -> Ref m a + -> m () +moveBranch mb r = moveRef r <=< embedBranch mb + +-- | With a 'MutBranch', attempt to clone out a branch of a mutable +-- @s@, if possible. +-- +-- @ +-- ghci> r <- thawRef (Left 10) +-- ghci> s <- cloneBranch (constrMB #_Left) +-- ghci> case s of Just s' -> freezeRef s' +-- 10 +-- @ +-- +-- @ +-- ghci> r <- thawRef (Right True) +-- ghci> s <- cloneBranch (constrMB #_Left) +-- ghci> case s of Nothing -> "it was Right" +-- "it was Right" +-- @ +cloneBranch + :: Mutable m a + => MutBranch m s a -- ^ How to check if @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of + -> m (Maybe (Ref m a)) +cloneBranch mb = mapM cloneRef <=< projectBranch mb + +-- | A non-copying version of 'freezeBranch' that can be more efficient +-- for types where the mutable representation is the same as the immutable +-- one (like 'V.Vector'). +-- +-- This is safe as long as you never again modify the mutable +-- reference, since it can potentially directly mutate the frozen value +-- magically. +unsafeFreezeBranch + :: Mutable m a + => MutBranch m s a -- ^ How to check if is @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of + -> m (Maybe a) +unsafeFreezeBranch mb = mapM unsafeFreezeRef <=< projectBranch mb + +-- | A non-copying version of 'thawBranch' that can be more efficient for +-- types where the mutable representation is the same as the immutable one +-- (like 'V.Vector'). +-- +-- This is safe as long as you never again use the original pure value, +-- since it can potentially directly mutate it. +unsafeThawBranch + :: Mutable m a + => MutBranch m s a + -> a + -> m (Ref m s) +unsafeThawBranch mb = embedBranch mb <=< unsafeThawRef + + +-- | With a 'MutBranch', if an @s@ is on the @a@ branch, perform an action +-- on the @a@ reference and overwrite the @s@ with the modified @a@. +-- Returns the result of the action, if @a@ was found. +-- +-- @ +-- ghci> r <- 'thawRef' (Just 10) +-- ghci> 'withBranch_' ('constrMB' #_Just) $ \i -> -- @i@ is an Int ref +-- .. 'modifyRef' i (+ 1) +-- ghci> 'freezeRef' r +-- Just 11 +-- @ +-- +-- @ +-- ghci> r <- thawRef Nothing +-- ghci> withBranch_ (constrMB #_Just) $ \i -> -- @i@ is an Int ref +-- .. modifyRef i (+ 1) +-- ghci> freezeRef r +-- Nothing +-- @ +withBranch + :: Mutable m a + => MutBranch m s a -- ^ How to check if is @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of and write into + -> (Ref m a -> m b) -- ^ Action to perform on the @a@ branch of @s@ + -> m (Maybe b) +withBranch mb r f = mapM f =<< projectBranch mb r + +-- | 'withBranch', but discarding the returned value. +withBranch_ + :: Mutable m a + => MutBranch m s a -- ^ How to check if is @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of and write into + -> (Ref m a -> m b) -- ^ Action to perform on the @a@ branch of @s@ + -> m () +withBranch_ mb r = void . withBranch mb r + +-- | With a 'MutBranch', run a pure function over a potential branch @a@ of +-- @s@. If @s@ is not on that branch, leaves @s@ unchanged. +-- +-- @ +-- ghci> r <- 'thawRef' (Just 10) +-- ghci> 'modifyBranch' ('constrMB' #_Just) r (+ 1) +-- ghci> freezeRef r +-- Just 11 +-- @ +-- +-- @ +-- ghci> r <- thawRef Nothing +-- ghci> modifyBranch (constrMB #_Just) r (+ 1) +-- ghci> freezeRef r +-- Nothing +-- @ +modifyBranch + :: Mutable m a + => MutBranch m s a -- ^ How to check if @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of and write into + -> (a -> a) -- ^ Pure function modifying @a@ + -> m () +modifyBranch mb r f = withBranch_ mb r (`modifyRef` f) + +-- | 'modifyBranch', but forces the result before storing it back in the +-- reference. +modifyBranch' + :: Mutable m a + => MutBranch m s a -- ^ How to check if @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of and write into + -> (a -> a) -- ^ Pure function modifying @a@ + -> m () +modifyBranch' mb r f = withBranch_ mb r (`modifyRef'` f) + +-- | 'modifyBranch' but for a monadic function. Uses 'copyRef' into the +-- reference after the action is completed. +modifyBranchM + :: Mutable m a + => MutBranch m s a -- ^ How to check if @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of and write into + -> (a -> m a) -- ^ Monadic function modifying @a@ + -> m () +modifyBranchM mb r f = withBranch_ mb r (`modifyRefM` f) + +-- | 'modifyBranchM', but forces the result before storing it back in the +-- reference. +modifyBranchM' + :: Mutable m a + => MutBranch m s a -- ^ How to check if @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of and write into + -> (a -> m a) -- ^ Monadic function modifying @a@ + -> m () +modifyBranchM' mb r f = withBranch_ mb r (`modifyRefM'` f) + +-- | With a 'MutBranch', run a pure function over a potential branch @a@ of +-- @s@. The function returns the updated @a@ and also an output value to +-- observe. If @s@ is not on that branch, leaves @s@ unchanged. +-- +-- @ +-- ghci> r <- 'thawRef' (Just 10) +-- ghci> 'updateBranch' ('constrMB' #_Just) r $ \i -> (i + 1, show i) +-- Just "10" +-- ghci> 'freezeRef' r +-- Just 11 +-- @ +-- +-- @ +-- ghci> r <- thawRef Nothing +-- ghci> updateBranch (constrMB #_Just) r $ \i -> (i + 1, show i) +-- Nothing +-- ghci> freezeRef r +-- Nothing +-- @ +updateBranch + :: Mutable m a + => MutBranch m s a -- ^ How to check if @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of and write into + -> (a -> (a, b)) + -> m (Maybe b) +updateBranch mb r f = withBranch mb r (`updateRef` f) + +-- | 'updateBranch', but forces the result before storing it back in the +-- reference. +updateBranch' + :: Mutable m a + => MutBranch m s a -- ^ How to check if @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of and write into + -> (a -> (a, b)) + -> m (Maybe b) +updateBranch' mb r f = withBranch mb r (`updateRef'` f) + +-- | 'updateBranch' but for a monadic function. Uses 'copyRef' into the +-- reference after the action is completed. +updateBranchM + :: Mutable m a + => MutBranch m s a -- ^ How to check if @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of and write into + -> (a -> m (a, b)) + -> m (Maybe b) +updateBranchM mb r f = withBranch mb r (`updateRefM` f) + +-- | 'updateBranchM', but forces the result before storing it back in the +-- reference. +updateBranchM' + :: Mutable m a + => MutBranch m s a -- ^ How to check if @s@ is an @a@ + -> Ref m s -- ^ Structure to read out of and write into + -> (a -> m (a, b)) + -> m (Maybe b) +updateBranchM' mb r f = withBranch mb r (`updateRefM'` f) + + + +-- | A version of 'Data.Vinyl.Derived.Label' that removes an underscore at +-- the beginning when used with -XOverloadedLabels. Used to specify +-- constructors, since labels are currently not able to start with capital +-- letters. +data CLabel (ctor :: Symbol) = CLabel + +instance (ctor_ ~ AppendSymbol "_" ctor) => IsLabel ctor_ (CLabel ctor) where + fromLabel = CLabel + + + +-- | Typeclass powering 'constrMB' using GHC Generics. +-- +-- Heavily inspired by "Data.Generics.Sum.Constructors". +class (GMutable m f, Mutable m a) => GMutBranchConstructor (ctor :: Symbol) m f a | ctor f -> a where + gmbcProj :: CLabel ctor -> GRef_ m f x -> m (Maybe (Ref m a)) + gmbcEmbed :: CLabel ctor -> Ref m a -> m (GRef_ m f x) + +instance + ( GMutable m f + , Mutable m a + , GL.GIsList (GRef_ m f) (GRef_ m f) (MapRef m as) (MapRef m as) + , GL.GIsList f f as as + , GL.ListTuple a as + , GL.ListTuple b (MapRef m as) + , Ref m a ~ b + ) + => GMutBranchConstructor ctor m (M1 C ('MetaCons ctor fixity fields) f) a where + gmbcProj _ = pure . Just . GL.listToTuple . GLP.view GL.glist . unM1 + gmbcEmbed _ = pure . M1 . GLP.view GL.glistR . GL.tupleToList + +instance GMutBranchConstructor ctor m f a => GMutBranchConstructor ctor m (M1 D meta f) a where + gmbcProj lb = gmbcProj lb . unM1 + gmbcEmbed lb = fmap M1 . gmbcEmbed lb + +instance + ( PrimMonad m + , Mutable m a + , GMutBranchSum ctor (GL.HasCtorP ctor l) m l r a + ) + => GMutBranchConstructor ctor m (l :+: r) a where + gmbcProj = gmbsProj @ctor @(GL.HasCtorP ctor l) + gmbcEmbed = gmbsEmbed @ctor @(GL.HasCtorP ctor l) + +class (GMutable m l, GMutable m r, Mutable m a) => GMutBranchSum (ctor :: Symbol) (contains :: Bool) m l r a | ctor l r -> a where + gmbsProj :: CLabel ctor -> MutSumF m (GRef_ m l) (GRef_ m r) x -> m (Maybe (Ref m a)) + gmbsEmbed :: CLabel ctor -> Ref m a -> m (MutSumF m (GRef_ m l) (GRef_ m r) x) + +instance + ( PrimMonad m + , GMutable m r + , GMutBranchConstructor ctor m l a + , GL.GIsList (GRef_ m l) (GRef_ m l) (MapRef m as) (MapRef m as) + , GL.GIsList l l as as + , GL.ListTuple a as + , GL.ListTuple b (MapRef m as) + , Ref m a ~ b + ) + => GMutBranchSum ctor 'True m l r a where + gmbsProj lb (MutSumF r) = readMutVar r >>= \case + L1 x -> gmbcProj lb x + R1 _ -> pure Nothing + gmbsEmbed _ = fmap MutSumF . newMutVar . L1 . GLP.view GL.glistR . GL.tupleToList + +instance + ( PrimMonad m + , GMutable m l + , GMutBranchConstructor ctor m r a + , GL.GIsList (GRef_ m r) (GRef_ m r) (MapRef m as) (MapRef m as) + , GL.GIsList r r as as + , GL.ListTuple a as + , GL.ListTuple b (MapRef m as) + , Ref m a ~ b + ) + => GMutBranchSum ctor 'False m l r a where + gmbsProj lb (MutSumF r) = readMutVar r >>= \case + L1 _ -> pure Nothing + R1 x -> gmbcProj lb x + gmbsEmbed _ = fmap MutSumF . newMutVar . R1 . GLP.view GL.glistR . GL.tupleToList + +-- | Create a 'MutBranch' for any data type with a 'Generic' instance by +-- specifying the constructor name using OverloadedLabels +-- +-- @ +-- ghci> r <- 'thawRef' (Left 10) +-- ghci> 'freezeBranch' ('constrMB' #_Left) r +-- Just 10 +-- ghci> freezeBranch (constrMB #_Right) r +-- Nothing +-- @ +-- +-- Note that due to limitations in OverloadedLabels, you must prefix the +-- constructor name with an undescore. +-- +-- There also isn't currently any way to utilize OverloadedLabels with +-- operator identifiers, so using it with operator constructors (like @:@ +-- and @[]@) requires explicit TypeApplications: +-- +-- @ +-- -- | 'MutBranch' focusing on the cons case of a list +-- consMB :: (PrimMonad m, Mutable m a) => MutBranch m [a] (a, [a]) +-- consMB = 'constrMB' ('CLabel' @":") +-- @ +constrMB + :: forall ctor m s a. + ( Ref m s ~ GRef m s + , GMutBranchConstructor ctor m (Rep s) a + ) + => CLabel ctor + -> MutBranch m s a +constrMB l = MutBranch + { projectBranch = gmbcProj l . unGRef + , embedBranch = fmap GRef . gmbcEmbed l + } + +-- | 'MutBranch' focusing on the nil case of a list +nilMB :: (PrimMonad m, Mutable m a) => MutBranch m [a] () +nilMB = constrMB (CLabel @"[]") + +-- | 'MutBranch' focusing on the cons case of a list +consMB :: (PrimMonad m, Mutable m a) => MutBranch m [a] (a, [a]) +consMB = constrMB (CLabel @":") + +-- | 'MutBranch' focusing on the 'Nothing' case of a 'Maybe' +nothingMB :: (PrimMonad m, Mutable m a) => MutBranch m (Maybe a) () +nothingMB = constrMB #_Nothing + +-- | 'MutBranch' focusing on the 'Just' case of a 'Maybe' +justMB :: (PrimMonad m, Mutable m a) => MutBranch m (Maybe a) a +justMB = constrMB #_Just + +-- | 'MutBranch' focusing on the 'Left' case of an 'Either' +leftMB :: (PrimMonad m, Mutable m a, Mutable m b) => MutBranch m (Either a b) a +leftMB = constrMB #_Left + +-- | 'MutBranch' focusing on the 'Right' case of an 'Either' +rightMB :: (PrimMonad m, Mutable m a, Mutable m b) => MutBranch m (Either a b) b +rightMB = constrMB #_Right diff --git a/src/Data/Mutable/Class.hs b/src/Data/Mutable/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mutable/Class.hs @@ -0,0 +1,356 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Data.Mutable.Class +-- Copyright : (c) Justin Le 2020 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Provides the 'Mutable' typeclass and various helpers. See +-- 'Data.Mutable' for the main "entrypoint". +module Data.Mutable.Class ( + Mutable(..) + , copyRefWhole, moveRefWhole, cloneRefWhole + , modifyRef, modifyRef' + , updateRef, updateRef' + , modifyRefM, modifyRefM' + , updateRefM, updateRefM' + , RefFor(..) + , DefaultMutable(..) + -- * Providing and overwriting instances + , VarMut(..) + , CoerceMut(..) + , TraverseMut(..) + , Immutable(..) + -- * Changing underlying monad + , reMutable, reMutableConstraint + -- * Util + , MapRef + ) where + +import Control.Monad +import Control.Monad.Primitive +import Data.Coerce +import Data.Constraint +import Data.Constraint.Unsafe +import Data.Kind +import Data.Mutable.Instances +import Data.Mutable.Internal +import Data.Primitive.MutVar +import Data.Proxy +import Data.Reflection +import GHC.Generics +import qualified Data.Vinyl.XRec as X + +-- | Apply a pure function on an immutable value onto a value stored in +-- a mutable reference. +modifyRef :: Mutable m a => Ref m a -> (a -> a) -> m () +modifyRef v f = copyRef v . f =<< freezeRef v +{-# INLINE modifyRef #-} + +-- | 'modifyRef', but forces the result before storing it back in the +-- reference. +modifyRef' :: Mutable m a => Ref m a -> (a -> a) -> m () +modifyRef' v f = (copyRef v $!) . f =<< freezeRef v +{-# INLINE modifyRef' #-} + +-- | Apply a monadic function on an immutable value onto a value stored in +-- a mutable reference. Uses 'copyRef' into the reference after the +-- action is completed. +modifyRefM :: Mutable m a => Ref m a -> (a -> m a) -> m () +modifyRefM v f = copyRef v =<< f =<< freezeRef v +{-# INLINE modifyRefM #-} + +-- | 'modifyRefM', but forces the result before storing it back in the +-- reference. +modifyRefM' :: Mutable m a => Ref m a -> (a -> m a) -> m () +modifyRefM' v f = (copyRef v $!) =<< f =<< freezeRef v +{-# INLINE modifyRefM' #-} + +-- | Apply a pure function on an immutable value onto a value stored in +-- a mutable reference, returning a result value from that function. +updateRef :: Mutable m a => Ref m a -> (a -> (a, b)) -> m b +updateRef v f = do + (x, y) <- f <$> freezeRef v + copyRef v x + return y + +-- | 'updateRef', but forces the updated value before storing it back in the +-- reference. +updateRef' :: Mutable m a => Ref m a -> (a -> (a, b)) -> m b +updateRef' v f = do + (x, y) <- f <$> freezeRef v + x `seq` copyRef v x + return y + +-- | Apply a monadic function on an immutable value onto a value stored in +-- a mutable reference, returning a result value from that function. Uses +-- 'copyRef' into the reference after the action is completed. +updateRefM :: Mutable m a => Ref m a -> (a -> m (a, b)) -> m b +updateRefM v f = do + (x, y) <- f =<< freezeRef v + copyRef v x + return y + +-- | 'updateRefM', but forces the updated value before storing it back in the +-- reference. +updateRefM' :: Mutable m a => Ref m a -> (a -> m (a, b)) -> m b +updateRefM' v f = do + (x, y) <- f =<< freezeRef v + x `seq` copyRef v x + return y + +-- | A default implementation of 'copyRef' using 'thawRef' and 'moveRef'. +copyRefWhole + :: Mutable m a + => Ref m a -- ^ destination to overwrite + -> a -- ^ pure value + -> m () +copyRefWhole r v = moveRef r =<< thawRef v +{-# INLINE copyRefWhole #-} + +-- | A default implementation of 'moveRef' that round-trips through the +-- pure type, using 'freezeRef' and 'copyRef'. It freezes the entire source +-- and then re-copies it into the destination. +moveRefWhole + :: Mutable m a + => Ref m a -- ^ destination + -> Ref m a -- ^ source + -> m () +moveRefWhole r v = copyRef r =<< freezeRef v +{-# INLINE moveRefWhole #-} + +-- | A default implementation of 'moveRef' that round-trips through the +-- pure type, using 'freezeRef' and 'thawRef'. It freezes the entire +-- source and then re-copies it into the destination. +cloneRefWhole + :: Mutable m a + => Ref m a + -> m (Ref m a) +cloneRefWhole = thawRef <=< freezeRef +{-# INLINE cloneRefWhole #-} + +-- | Newtype wrapper that can provide any type with a 'Mutable' instance, +-- giving it a "non-piecewise" instance. Can be useful for avoiding orphan +-- instances yet still utilizing auto-deriving features, or for overwriting +-- the 'Mutable' instance of other instances. +-- +-- For example, let's say you want to auto-derive an instance for your data +-- type: +-- +-- @ +-- data MyType = MT Int Double OtherType +-- deriving Generic +-- @ +-- +-- This is possible if all of @MyType@s fields have 'Mutable' instances. +-- However, let's say @OtherType@ comes from an external library that you +-- don't have control over, and so you cannot give it a 'Mutable' instance +-- without incurring an orphan instance. +-- +-- One solution is to wrap it in 'VarMut': +-- +-- @ +-- data MyType = MT Int Double ('VarMut' OtherType) +-- deriving Generic +-- @ +-- +-- This can then be auto-derived: +-- +-- @ +-- instance Mutable m MyType where +-- type Ref m MyType = GRef m MyType +-- @ +-- +-- It can also be used to /override/ a 'Mutable' instance. For example, +-- even if the 'Mutable' instance of @SomeType@ is piecewise-mutable, the +-- 'Mutable' instance of @'VarMut' SomeType@ will be not be piecewise. +-- +-- For example, the 'Mutable' instance for 'String' is a mutable linked +-- list, but it might be more efficient to treat it as an atomic value to +-- update all at once. You can use @'VarMut' 'String'@ to get that +-- 'Mutable' instance. +newtype VarMut a = VarMut { getVarMut :: a } + +-- | Use a @'VarMut' a@ as if it were an @a@. +instance X.IsoHKD VarMut a where + type HKD VarMut a = a + unHKD = VarMut + toHKD = getVarMut + +instance PrimMonad m => Mutable m (VarMut a) where + type Ref m (VarMut a) = MutVar (PrimState m) (VarMut a) + + +-- | Similar to 'VarMut', this allows you to overwrite the normal 'Mutable' +-- instance for a type to utilize its 'Traversable' instance instead of its +-- normal instance. It's also useful to provide an instance for an +-- externally defined type without incurring orphan instances. +-- +-- For example, the instance of @'Mutable' ('TraverseMut' [] a)@ is +-- a normal list of mutable references, instead of a full-on mutable linked +-- list. +newtype TraverseMut f a = TraverseMut { getTraverseMut :: f a } + deriving (Show, Eq, Ord, Generic, Functor, Foldable, Traversable) + +-- | Use a @'TraverseMut' f a@ as if it were an @f a@ +instance X.IsoHKD (TraverseMut f) a where + type HKD (TraverseMut f) a = f a + unHKD = TraverseMut + toHKD = getTraverseMut + +instance (Traversable f, Mutable m a) => Mutable m (TraverseMut f a) where + type Ref m (TraverseMut f a) = TraverseRef m (TraverseMut f) a + +-- | Similar to 'VarMut', this allows you to overwrite the normal 'Mutable' +-- instance of a type to utilize a coercible type's 'Mutable' instance +-- instead of its normal instance. It's also useful to provide an instance for +-- an externally defined type without incurring orphan instances. +-- +-- For example, if an external library provides +-- +-- @ +-- newtype DoubleVec = DV (Vector Double) +-- @ +-- +-- and you want to use it following 'V.Vector's 'Mutable' instance (via +-- 'MV.MVector'), but you don't want to write an orphan instance like +-- +-- @ +-- instance Mutable m DoubleVec where +-- type 'Ref' m DoubleVec = 'CoerceRef' m DoubleVec (Vector Double) +-- @ +-- +-- then you can instead use @'CoerceMut' DoubleVec (Vector Double)@ as the +-- data type. This wrapped type /does/ use the inderlying 'Mutable' +-- insatnce for 'V.Vector'. +newtype CoerceMut s a = CoerceMut { getCoerceMut :: s } + +-- | Use a @'CoerceMut' s a@ as if it were an @s@ +instance X.IsoHKD (CoerceMut s) a where + type HKD (CoerceMut s) a = s + unHKD = CoerceMut + toHKD = getCoerceMut + +instance (Mutable m a, Coercible s a) => Mutable m (CoerceMut s a) where + type Ref m (CoerceMut s a) = CoerceRef m (CoerceMut s a) a + +-- | Similar to 'VarMut', this allows you to overwrite the normal 'Mutable' +-- instance of a type to make it /immutable/. +-- +-- For example, let's say you have a type, with the automatically derived +-- generic instance of 'Mutable': +-- +-- @ +-- data MyType = MT +-- { mtX :: Int +-- , mtY :: Vector Double +-- , mtZ :: String +-- } +-- deriving Generic +-- +-- instance Mutable m MyType where +-- type Ref m MyType = GRef m MyType +-- @ +-- +-- This basically uses three mutable references: the 'Int', the @'V.Vector' +-- Double@, and the 'String'. However, you might want the 'Mutable' +-- instance of @MyType@ to be /immutable/ 'String' field, and so it cannot +-- be updated at all even when thawed. To do that, you can instead have: +-- +-- @ +-- data MyType = MT +-- { mtX :: Int +-- , mtY :: Vector Double +-- , mtZ :: 'Immutable' String +-- } +-- deriving Generic +-- +-- instance Mutable m MyType where +-- type Ref m MyType = GRef m MyType +-- @ +-- +-- which has that behavior. The 'Int' and the 'V.Vector' will be mutable +-- within @'Ref' m MyType@, but not the 'String'. +newtype Immutable a = Immutable { getImmutable :: a } + +-- | Use an @'Immutable' a@ as if it were an @a@ +instance X.IsoHKD Immutable a where + type HKD Immutable a = a + unHKD = Immutable + toHKD = getImmutable + + +instance Monad m => Mutable m (Immutable a) where + type Ref m (Immutable a) = ImmutableRef (Immutable a) + + +newtype ReMutable (s :: Type) m a = ReMutable a +newtype ReMutableTrans m n = RMT { runRMT :: forall x. m x -> n x } + +instance (Monad n, Mutable m a, Reifies s (ReMutableTrans m n)) => Mutable n (ReMutable s m a) where + type Ref n (ReMutable s m a) = ReMutable s m (Ref m a) + thawRef (ReMutable x) = runRMT rmt $ ReMutable <$> thawRef @m @a x + where + rmt = reflect (Proxy @s) + freezeRef (ReMutable v) = runRMT rmt $ ReMutable <$> freezeRef @m @a v + where + rmt = reflect (Proxy @s) + copyRef (ReMutable x) (ReMutable v) = runRMT rmt $ copyRef @m @a x v + where + rmt = reflect (Proxy @s) + moveRef (ReMutable x) (ReMutable v) = runRMT rmt $ moveRef @m @a x v + where + rmt = reflect (Proxy @s) + cloneRef (ReMutable x) = runRMT rmt $ ReMutable <$> cloneRef @m @a x + where + rmt = reflect (Proxy @s) + unsafeThawRef (ReMutable x) = runRMT rmt $ ReMutable <$> unsafeThawRef @m @a x + where + rmt = reflect (Proxy @s) + unsafeFreezeRef (ReMutable v) = runRMT rmt $ ReMutable <$> unsafeFreezeRef @m @a v + where + rmt = reflect (Proxy @s) + +unsafeReMutable :: forall s m n a. Mutable n (ReMutable s m a) :- Mutable n a +unsafeReMutable = unsafeCoerceConstraint + +-- | If you can provice a natural transformation from @m@ to @n@, you +-- should be able to use a value as if it had @'Mutable' n a@ if you have +-- @'Mutable' m a@. +reMutable + :: forall m n a r. (Mutable m a, Monad n) + => (forall x. m x -> n x) + -> (Mutable n a => r) + -> r +reMutable f x = x \\ reMutableConstraint @m @n @a f + +-- | If you can provice a natural transformation from @m@ to @n@, then +-- @'Mutable' m a@ should also imply @'Mutable' n a@. +reMutableConstraint + :: forall m n a. (Mutable m a, Monad n) + => (forall x. m x -> n x) + -> Mutable m a :- Mutable n a +reMutableConstraint f = reify (RMT f) $ \(Proxy :: Proxy s) -> + case unsafeReMutable @s @m @n @a of + Sub Data.Constraint.Dict -> Sub Data.Constraint.Dict + + diff --git a/src/Data/Mutable/Instances.hs b/src/Data/Mutable/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mutable/Instances.hs @@ -0,0 +1,476 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Data.Mutable.Instances +-- Copyright : (c) Justin Le 2020 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Provides 'Ref' instances for various data types, as well as automatic +-- derivation of instances. See "Data.Mutable" for more information. +module Data.Mutable.Instances ( + RecRef(..) + , HListRef(..) + -- * Generic + , GRef(..) + , gThawRef, gFreezeRef + , gCopyRef, gMoveRef, gCloneRef + , gUnsafeThawRef, gUnsafeFreezeRef + , GMutable (GRef_) + -- * Higher-Kinded Data Pattern + , thawHKD, freezeHKD + , copyHKD, moveHKD, cloneHKD + , unsafeThawHKD, unsafeFreezeHKD + -- * Coercible + , CoerceRef(..) + , thawCoerce, freezeCoerce + , copyCoerce, moveCoerce, cloneCoerce + , unsafeThawCoerce, unsafeFreezeCoerce + -- * Traversable + , TraverseRef(..) + , thawTraverse, freezeTraverse + , copyTraverse, moveTraverse, cloneTraverse + , unsafeThawTraverse, unsafeFreezeTraverse + -- * Immutable + , ImmutableRef(..), thawImmutable, freezeImmutable, copyImmutable + -- * Instances for Generics combinators themselves + , GMutableRef(..) + , MutSumF(..) + -- * Utility + , MapRef + ) where + +import Control.Applicative +import Control.Monad.Primitive +import Data.Complex +import Data.Functor.Compose +import Data.Functor.Identity +import Data.Functor.Product +import Data.Functor.Sum +import Data.GenericLens.Internal (HList(..)) +import Data.Kind +import Data.Mutable.Internal +import Data.Ord +import Data.Primitive.Array +import Data.Primitive.ByteArray +import Data.Primitive.PrimArray +import Data.Primitive.SmallArray +import Data.Primitive.Types +import Data.Ratio +import Data.Vinyl as V hiding (HList) +import Data.Void +import Data.Word +import Foreign.C.Types +import Foreign.Storable +import Numeric.Natural +import qualified Data.Monoid as M +import qualified Data.Vector as V +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as MVG +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Primitive.Mutable as MVP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as MVS +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as MVU +import qualified Data.Vinyl.ARec as V +import qualified Data.Vinyl.Functor as V +import qualified Data.Vinyl.TypeLevel as V + +instance PrimMonad m => Mutable m Int +instance PrimMonad m => Mutable m Integer +instance PrimMonad m => Mutable m Natural +instance PrimMonad m => Mutable m (Ratio a) +instance PrimMonad m => Mutable m Float +instance PrimMonad m => Mutable m Double +instance PrimMonad m => Mutable m (Complex a) +instance PrimMonad m => Mutable m Bool +instance PrimMonad m => Mutable m Char + +instance PrimMonad m => Mutable m Word +instance PrimMonad m => Mutable m Word8 +instance PrimMonad m => Mutable m Word16 +instance PrimMonad m => Mutable m Word64 + +instance PrimMonad m => Mutable m CChar +instance PrimMonad m => Mutable m CSChar +instance PrimMonad m => Mutable m CUChar +instance PrimMonad m => Mutable m CShort +instance PrimMonad m => Mutable m CUShort +instance PrimMonad m => Mutable m CInt +instance PrimMonad m => Mutable m CUInt +instance PrimMonad m => Mutable m CLong +instance PrimMonad m => Mutable m CULong +instance PrimMonad m => Mutable m CPtrdiff +instance PrimMonad m => Mutable m CSize +instance PrimMonad m => Mutable m CWchar +instance PrimMonad m => Mutable m CSigAtomic +instance PrimMonad m => Mutable m CLLong +instance PrimMonad m => Mutable m CULLong +instance PrimMonad m => Mutable m CBool +instance PrimMonad m => Mutable m CIntPtr +instance PrimMonad m => Mutable m CUIntPtr +instance PrimMonad m => Mutable m CIntMax +instance PrimMonad m => Mutable m CUIntMax +instance PrimMonad m => Mutable m CClock +instance PrimMonad m => Mutable m CTime +instance PrimMonad m => Mutable m CUSeconds +instance PrimMonad m => Mutable m CSUSeconds +instance PrimMonad m => Mutable m CFloat +instance PrimMonad m => Mutable m CDouble + +instance Mutable m a => Mutable m (Identity a) where + type Ref m (Identity a) = CoerceRef m (Identity a) a + +instance Mutable m a => Mutable m (Const a b) where + type Ref m (Const a b) = CoerceRef m (Const a b) a + +instance Mutable m a => Mutable m (V.Const a b) where + type Ref m (V.Const a b) = CoerceRef m (V.Const a b) a + +instance Mutable m a => Mutable m (M.Product a) where + type Ref m (M.Product a) = CoerceRef m (M.Product a) a + +instance Mutable m a => Mutable m (M.Sum a) where + type Ref m (M.Sum a) = CoerceRef m (M.Sum a) a + +instance Mutable m a => Mutable m (Down a) where + type Ref m (Down a) = CoerceRef m (Down a) a + +instance Mutable m a => Mutable m (M.Dual a) where + type Ref m (M.Dual a) = CoerceRef m (M.Dual a) a + +instance (Mutable m a, PrimMonad m) => Mutable m (Maybe a) where + type Ref m (Maybe a) = GRef m (Maybe a) + +instance (Mutable m a, Mutable m b, PrimMonad m) => Mutable m (Either a b) where + type Ref m (Either a b) = GRef m (Either a b) + +instance (Mutable m (f a), Mutable m (g a)) => Mutable m (Product f g a) where + type Ref m (Product f g a) = GRef m (Product f g a) + +instance (Mutable m (f a), Mutable m (g a), PrimMonad m) => Mutable m (Sum f g a) where + type Ref m (Sum f g a) = GRef m (Sum f g a) + +instance (Mutable m (f (g a))) => Mutable m (Compose f g a) where + type Ref m (Compose f g a) = CoerceRef m (Compose f g a) (f (g a)) + +-- | Mutable linked list with mutable references in each cell. See +-- 'Data.Mutable.MutBranch' documentation for an example of using this as +-- a mutable linked list.l +instance (PrimMonad m, Mutable m a) => Mutable m [a] where + type Ref m [a] = GRef m [a] + +-- | Meant for usage with higher-kinded data pattern (See 'X.HKD') +instance Mutable m a => Mutable m (V.Identity a) where + type Ref m (V.Identity a) = RefFor m a + thawRef (V.Identity x) = RefFor <$> thawRef x + freezeRef (RefFor r) = V.Identity <$> freezeRef r + copyRef (RefFor r) (V.Identity x) = copyRef r x + moveRef (RefFor r) (RefFor v) = moveRef r v + cloneRef = fmap RefFor . cloneRef . getRefFor + unsafeThawRef (V.Identity x) = RefFor <$> unsafeThawRef x + unsafeFreezeRef (RefFor r) = V.Identity <$> unsafeFreezeRef r + +-- | Mutable reference is 'MV.MVector'. +instance PrimMonad m => Mutable m (V.Vector a) where + type Ref m (V.Vector a) = MV.MVector (PrimState m) a + thawRef = VG.thaw + freezeRef = VG.freeze + copyRef = VG.copy + moveRef = MVG.move + cloneRef = MVG.clone + unsafeThawRef = VG.unsafeThaw + unsafeFreezeRef = VG.unsafeFreeze + +-- | Mutable reference is 'MVS.MVector'. +instance (PrimMonad m, Storable a) => Mutable m (VS.Vector a) where + type Ref m (VS.Vector a) = MVS.MVector (PrimState m) a + thawRef = VG.thaw + freezeRef = VG.freeze + copyRef = VG.copy + moveRef = MVG.move + cloneRef = MVG.clone + unsafeThawRef = VG.unsafeThaw + unsafeFreezeRef = VG.unsafeFreeze + +-- | Mutable reference is 'MVU.MVector'. +instance (PrimMonad m, VU.Unbox a) => Mutable m (VU.Vector a) where + type Ref m (VU.Vector a) = MVU.MVector (PrimState m) a + thawRef = VG.thaw + freezeRef = VG.freeze + copyRef = VG.copy + moveRef = MVG.move + cloneRef = MVG.clone + unsafeThawRef = VG.unsafeThaw + unsafeFreezeRef = VG.unsafeFreeze + +-- | Mutable reference is 'MVP.MVector'. +instance (PrimMonad m, Prim a) => Mutable m (VP.Vector a) where + type Ref m (VP.Vector a) = MVP.MVector (PrimState m) a + thawRef = VG.thaw + freezeRef = VG.freeze + copyRef = VG.copy + moveRef = MVG.move + cloneRef = MVG.clone + unsafeThawRef = VG.unsafeThaw + unsafeFreezeRef = VG.unsafeFreeze + +instance PrimMonad m => Mutable m (Array a) where + type Ref m (Array a) = MutableArray (PrimState m) a + + thawRef xs = thawArray xs 0 (sizeofArray xs) + freezeRef rs = freezeArray rs 0 (sizeofMutableArray rs) + copyRef rs xs = copyArray rs 0 xs 0 l + where + l = sizeofArray xs `min` sizeofMutableArray rs + moveRef rs vs = copyMutableArray rs 0 vs 0 l + where + l = sizeofMutableArray vs `min` sizeofMutableArray rs + cloneRef rs = cloneMutableArray rs 0 (sizeofMutableArray rs) + unsafeThawRef = unsafeThawArray + unsafeFreezeRef = unsafeFreezeArray + +instance PrimMonad m => Mutable m (SmallArray a) where + type Ref m (SmallArray a) = SmallMutableArray (PrimState m) a + + thawRef xs = thawSmallArray xs 0 (sizeofSmallArray xs) + freezeRef rs = freezeSmallArray rs 0 (sizeofSmallMutableArray rs) + copyRef rs xs = copySmallArray rs 0 xs 0 l + where + l = sizeofSmallArray xs `min` sizeofSmallMutableArray rs + moveRef rs vs = copySmallMutableArray rs 0 vs 0 l + where + l = sizeofSmallMutableArray vs `min` sizeofSmallMutableArray rs + cloneRef rs = cloneSmallMutableArray rs 0 (sizeofSmallMutableArray rs) + unsafeThawRef = unsafeThawSmallArray + unsafeFreezeRef = unsafeFreezeSmallArray + +instance PrimMonad m => Mutable m ByteArray where + type Ref m ByteArray = MutableByteArray (PrimState m) + + thawRef xs = do + rs <- newByteArray (sizeofByteArray xs) + copyByteArray rs 0 xs 0 (sizeofByteArray xs) + pure rs + freezeRef rs = do + xs <- newByteArray (sizeofMutableByteArray rs) + copyMutableByteArray xs 0 rs 0 (sizeofMutableByteArray rs) + unsafeFreezeByteArray xs + copyRef rs xs = copyByteArray rs 0 xs 0 l + where + l = sizeofByteArray xs `min` sizeofMutableByteArray rs + moveRef rs vs = copyMutableByteArray rs 0 vs 0 l + where + l = sizeofMutableByteArray vs `min` sizeofMutableByteArray rs + cloneRef rs = do + vs <- newByteArray (sizeofMutableByteArray rs) + copyMutableByteArray vs 0 rs 0 (sizeofMutableByteArray rs) + pure vs + unsafeThawRef = unsafeThawByteArray + unsafeFreezeRef = unsafeFreezeByteArray + +instance (PrimMonad m, Prim a) => Mutable m (PrimArray a) where + type Ref m (PrimArray a) = MutablePrimArray (PrimState m) a + + thawRef xs = do + rs <- newPrimArray (sizeofPrimArray xs) + copyPrimArray rs 0 xs 0 (sizeofPrimArray xs) + pure rs + freezeRef rs = do + xs <- newPrimArray (sizeofMutablePrimArray rs) + copyMutablePrimArray xs 0 rs 0 (sizeofMutablePrimArray rs) + unsafeFreezePrimArray xs + copyRef rs xs = copyPrimArray rs 0 xs 0 l + where + l = sizeofPrimArray xs `min` sizeofMutablePrimArray rs + moveRef rs vs = copyMutablePrimArray rs 0 vs 0 l + where + l = sizeofMutablePrimArray vs `min` sizeofMutablePrimArray rs + cloneRef rs = do + vs <- newPrimArray (sizeofMutablePrimArray rs) + copyMutablePrimArray vs 0 rs 0 (sizeofMutablePrimArray rs) + pure vs + unsafeThawRef = unsafeThawPrimArray + unsafeFreezeRef = unsafeFreezePrimArray + + + + +instance Monad m => Mutable m Void where + type Ref m Void = Void + thawRef = \case {} + freezeRef = \case {} + copyRef = \case {} + moveRef = \case {} + cloneRef = \case {} + unsafeThawRef = \case {} + unsafeFreezeRef = \case {} + +instance Monad m => Mutable m () where + type Ref m () = () + thawRef _ = pure () + freezeRef _ = pure () + copyRef _ _ = pure () + moveRef _ _ = pure () + cloneRef _ = pure () + unsafeThawRef _ = pure () + unsafeFreezeRef _ = pure () + +-- | A 'Ref' of a tuple is a tuple of 'Ref's, for easy accessing. +-- +-- @ +-- Ref m (Int, 'V.Vector' Double) = ('Data.Primitive.MutVar.MutVar' s Int, 'MV.MVector' s Double) +-- @ +instance (Monad m, Mutable m a, Mutable m b) => Mutable m (a, b) where + type Ref m (a, b) = (Ref m a, Ref m b) + thawRef (!x, !y) = (,) <$> thawRef x <*> thawRef y + freezeRef (u , v ) = (,) <$> freezeRef u <*> freezeRef v + copyRef (u , v ) (!x, !y) = copyRef u x *> copyRef v y + moveRef (u , v ) ( x, y) = moveRef u x *> moveRef v y + cloneRef (x , y ) = (,) <$> cloneRef x <*> cloneRef y + unsafeThawRef (!x, !y) = (,) <$> unsafeThawRef x <*> unsafeThawRef y + unsafeFreezeRef (u , v ) = (,) <$> unsafeFreezeRef u <*> unsafeFreezeRef v + +-- | A 'Ref' of a tuple is a tuple of 'Ref's, for easy accessing. +instance (Monad m, Mutable m a, Mutable m b, Mutable m c) => Mutable m (a, b, c) where + type Ref m (a, b, c) = (Ref m a, Ref m b, Ref m c) + thawRef (!x, !y, !z) = (,,) <$> thawRef x <*> thawRef y <*> thawRef z + freezeRef (u , v , w ) = (,,) <$> freezeRef u <*> freezeRef v <*> freezeRef w + copyRef (u , v , w ) (!x, !y, !z) = copyRef u x *> copyRef v y *> copyRef w z + moveRef (u , v , w ) ( x, y, z) = moveRef u x *> moveRef v y *> moveRef w z + cloneRef (x , y , z ) = (,,) <$> cloneRef x <*> cloneRef y <*> cloneRef z + unsafeThawRef (!x, !y, !z) = (,,) <$> unsafeThawRef x <*> unsafeThawRef y <*> unsafeThawRef z + unsafeFreezeRef (u , v , w ) = (,,) <$> unsafeFreezeRef u <*> unsafeFreezeRef v <*> unsafeFreezeRef w + +-- | A 'Ref' of a tuple is a tuple of 'Ref's, for easy accessing. +instance (Monad m, Mutable m a, Mutable m b, Mutable m c, Mutable m d) => Mutable m (a, b, c, d) where + type Ref m (a, b, c, d) = (Ref m a, Ref m b, Ref m c, Ref m d) + thawRef (!x, !y, !z, !a) = (,,,) <$> thawRef x <*> thawRef y <*> thawRef z <*> thawRef a + freezeRef (u , v , w , j ) = (,,,) <$> freezeRef u <*> freezeRef v <*> freezeRef w <*> freezeRef j + copyRef (u , v , w , j ) (!x, !y, !z, !a) = copyRef u x *> copyRef v y *> copyRef w z *> copyRef j a + moveRef (u , v , w , j ) ( x, y, z, a) = moveRef u x *> moveRef v y *> moveRef w z *> moveRef j a + cloneRef (x , y , z , a ) = (,,,) <$> cloneRef x <*> cloneRef y <*> cloneRef z <*> cloneRef a + unsafeThawRef (!x, !y, !z, !a) = (,,,) <$> unsafeThawRef x <*> unsafeThawRef y <*> unsafeThawRef z <*> unsafeThawRef a + unsafeFreezeRef (u , v , w , j ) = (,,,) <$> unsafeFreezeRef u <*> unsafeFreezeRef v <*> unsafeFreezeRef w <*> unsafeFreezeRef j + +-- | A 'Ref' of a tuple is a tuple of 'Ref's, for easy accessing. +instance (Monad m, Mutable m a, Mutable m b, Mutable m c, Mutable m d, Mutable m e) => Mutable m (a, b, c, d, e) where + type Ref m (a, b, c, d, e) = (Ref m a, Ref m b, Ref m c, Ref m d, Ref m e) + thawRef (!x, !y, !z, !a, !b) = (,,,,) <$> thawRef x <*> thawRef y <*> thawRef z <*> thawRef a <*> thawRef b + freezeRef (u , v , w , j , k ) = (,,,,) <$> freezeRef u <*> freezeRef v <*> freezeRef w <*> freezeRef j <*> freezeRef k + copyRef (u , v , w , j , k ) (!x, !y, !z, !a, !b) = copyRef u x *> copyRef v y *> copyRef w z *> copyRef j a *> copyRef k b + moveRef (u , v , w , j , k ) ( x, y, z, a, b) = moveRef u x *> moveRef v y *> moveRef w z *> moveRef j a *> moveRef k b + cloneRef (x , y , z , a , b ) = (,,,,) <$> cloneRef x <*> cloneRef y <*> cloneRef z <*> cloneRef a <*> cloneRef b + unsafeThawRef (!x, !y, !z, !a, !b) = (,,,,) <$> unsafeThawRef x <*> unsafeThawRef y <*> unsafeThawRef z <*> unsafeThawRef a <*> unsafeThawRef b + unsafeFreezeRef (u , v , w , j , k ) = (,,,,) <$> unsafeFreezeRef u <*> unsafeFreezeRef v <*> unsafeFreezeRef w <*> unsafeFreezeRef j <*> unsafeFreezeRef k + +-- | 'Ref' for components in a vinyl 'Rec'. +newtype RecRef m f a = RecRef { getRecRef :: Ref m (f a) } + +deriving instance Eq (Ref m (f a)) => Eq (RecRef m f a) +deriving instance Ord (Ref m (f a)) => Ord (RecRef m f a) + +instance Monad m => Mutable m (Rec f '[]) where + type Ref m (Rec f '[]) = Rec (RecRef m f) '[] + thawRef _ = pure RNil + freezeRef _ = pure RNil + copyRef _ _ = pure () + moveRef _ _ = pure () + cloneRef _ = pure RNil + unsafeThawRef _ = pure RNil + unsafeFreezeRef _ = pure RNil + +instance (Monad m, Mutable m (f a), Mutable m (Rec f as), Ref m (Rec f as) ~ Rec (RecRef m f) as) => Mutable m (Rec f (a ': as)) where + type Ref m (Rec f (a ': as)) = Rec (RecRef m f) (a ': as) + thawRef = \case + x :& xs -> (:&) <$> (RecRef <$> thawRef x) <*> thawRef xs + freezeRef = \case + RecRef v :& vs -> (:&) <$> freezeRef v <*> freezeRef vs + copyRef = \case + RecRef v :& vs -> \case + x :& xs -> copyRef v x >> copyRef vs xs + moveRef = \case + RecRef v :& vs -> \case + RecRef r :& rs -> + moveRef v r >> moveRef vs rs + cloneRef = \case + RecRef v :& rs -> (:&) <$> (RecRef <$> cloneRef v) <*> cloneRef rs + unsafeThawRef = \case + x :& xs -> (:&) <$> (RecRef <$> unsafeThawRef x) <*> unsafeThawRef xs + unsafeFreezeRef = \case + RecRef v :& vs -> (:&) <$> unsafeFreezeRef v <*> unsafeFreezeRef vs + + +instance (Monad m, RecApplicative as, V.NatToInt (V.RLength as), RPureConstrained (V.IndexableField as) as, Mutable m (Rec f as), Ref m (Rec f as) ~ Rec (RecRef m f) as) => Mutable m (ARec f as) where + type Ref m (ARec f as) = ARec (RecRef m f) as + + thawRef = fmap toARec . thawRef . fromARec + freezeRef = fmap toARec . freezeRef . fromARec + copyRef r x = copyRef (fromARec r) (fromARec x) + moveRef r v = moveRef (fromARec r) (fromARec v) + cloneRef = fmap toARec . cloneRef . fromARec + unsafeThawRef = fmap toARec . unsafeThawRef . fromARec + unsafeFreezeRef = fmap toARec . unsafeFreezeRef . fromARec + +-- | Useful type family to @'Ref' m@ over every item in a type-level list +-- +-- @ +-- ghci> :kind! MapRef IO '[Int, V.Vector Double] +-- '[ MutVar RealWorld Int, MVector RealWorld Double ] +-- @ +type family MapRef m as where + MapRef m '[] = '[] + MapRef m (a ': as) = Ref m a ': MapRef m as + +-- | The mutable reference of the 'HList' type from generic-lens. +data HListRef :: (Type -> Type) -> [Type] -> Type where + NilRef :: HListRef m '[] + (:!>) :: Ref m a -> HListRef m as -> HListRef m (a ': as) +infixr 5 :!> + +instance Monad m => Mutable m (HList '[]) where + type Ref m (HList '[]) = HListRef m '[] + thawRef _ = pure NilRef + freezeRef _ = pure Nil + copyRef _ _ = pure () + moveRef _ _ = pure () + cloneRef _ = pure NilRef + unsafeThawRef _ = pure NilRef + unsafeFreezeRef _ = pure Nil + +instance (Monad m, Mutable m a, Mutable m (HList as), Ref m (HList as) ~ HListRef m as) => Mutable m (HList (a ': as)) where + type Ref m (HList (a ': as)) = HListRef m (a ': as) + thawRef = \case + x :> xs -> (:!>) <$> thawRef x <*> thawRef xs + freezeRef = \case + v :!> vs -> (:>) <$> freezeRef v <*> freezeRef vs + copyRef = \case + v :!> vs -> \case + x :> xs -> copyRef v x >> copyRef vs xs + moveRef = \case + v :!> vs -> \case + r :!> rs -> + moveRef v r >> moveRef vs rs + cloneRef = \case + v :!> rs -> (:!>) <$> cloneRef v <*> cloneRef rs + unsafeThawRef = \case + x :> xs -> (:!>) <$> unsafeThawRef x <*> unsafeThawRef xs + unsafeFreezeRef = \case + v :!> vs -> (:>) <$> unsafeFreezeRef v <*> unsafeFreezeRef vs diff --git a/src/Data/Mutable/Internal.hs b/src/Data/Mutable/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mutable/Internal.hs @@ -0,0 +1,1244 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Mutable.Internal ( + Mutable(..) + , RefFor(..) + , DefaultMutable(..) + -- * Instances + -- ** Generic + , GRef(..) + , gThawRef, gFreezeRef + , gCopyRef, gMoveRef, gCloneRef + , gUnsafeThawRef, gUnsafeFreezeRef + , GMutable (GRef_) + -- ** Higher-Kinded Data Pattern + , thawHKD, freezeHKD + , copyHKD, moveHKD, cloneHKD + , unsafeThawHKD, unsafeFreezeHKD + -- ** Coercible + , CoerceRef(..) + , thawCoerce, freezeCoerce + , copyCoerce, moveCoerce, cloneCoerce + , unsafeThawCoerce, unsafeFreezeCoerce + -- ** Traversable + , TraverseRef(..) + , thawTraverse, freezeTraverse + , copyTraverse, moveTraverse, cloneTraverse + , unsafeThawTraverse, unsafeFreezeTraverse + -- ** Immutable + , ImmutableRef(..), thawImmutable, freezeImmutable, copyImmutable + -- ** Instances for Generics combinators themselves + , GMutableRef(..) + , MutSumF(..) + ) where + +import Control.Monad.Primitive +import Control.Monad.Trans.Class +import Control.Monad.Trans.State +import Data.Bifunctor +import Data.Coerce +import Data.Foldable +import Data.Kind +import Data.List +import Data.Primitive.MutVar +import Data.Vinyl.Functor +import GHC.Generics +import qualified Data.Vinyl.XRec as X + +-- | An instance of @'Mutable' m a@ means that @a@ can be stored +-- a mutable reference in monad @m@. +-- +-- The associated type @'Ref' m a@ links any @a@ to the type of its +-- canonical mutable version. +-- +-- The /benefit/ of this typeclass, instead of just using +-- 'Data.IORef.IORef' or 'MutVar' or specific mutable versions like +-- 'V.Vector' and 'MV.MVector', is two-fold: +-- +-- * Piecewise-mutable values, so you can write to only one part and not +-- others. This also allows for cheaper "writes", even if you replace +-- the whole value: you don't need to ever synthesize an entire new +-- value, you can keep each component in a separate variable until you +-- 'freezeRef' it out. This can be especially useful for composite +-- data types containing large structures like 'V.Vector'. +-- * Generic abstractions (similar to 'Show'), so you can automatically +-- derive instances while preserving piecewise-ness. For example, the +-- instance +-- +-- @ +-- instance (Mutable m a, Mutable m b) => Mutable m (a, b) +-- @ +-- +-- If @a@ and @b@ are piecwise-mutable, then the instance here will +-- appropriately utilize that fact. +-- +-- To modify the specific parts of mutable values, it can be useful to use +-- the functions in "Data.Mutable.Parts". +-- +-- There are facilities to automatically piecewise mutable versions for +-- user-defined instances of 'Generic'. +-- +-- For example, if we have a type like: +-- +-- @ +-- data TwoVectors = TV +-- { tvInt :: 'V.Vector' Int +-- , tvDouble :: Vector Double +-- } +-- deriving Generic +-- +-- instance Mutable m TwoVectors where +-- type Ref m TwoVectors = 'GRef' m TwoVectors +-- @ +-- +-- Then now we get: +-- +-- @ +-- 'thawRef' :: TwoVectors -> m ('GRef' m TwoVectors) +-- 'freezeRef' :: 'GRef' m TwoVectors -> m TwoVectors +-- @ +-- +-- And @'GRef' m TwoVectors@ is now a piecewise-mutable reference storing each +-- part in a way that can be modified separately (for example, with tools +-- from "Data.Mutable.Parts"). It does this by internally allocating two +-- 'MV.MVector's. If the two vectors are large, this can be much more +-- efficient to modify (if you are modifying /several times/) than by just +-- doing alterations on @TwoVector@s. It is also much better for large +-- vectors if you plan on modifying only a single item in the vector. +-- +-- If you are using the "higher-kinded" data pattern, a la +-- , then we +-- can also do: +-- +-- @ +-- data TwoVectors f = TV +-- { tvInt :: 'X.HKD' f ('V.Vector' Int) +-- , tvDouble :: HKD f (Vector Double) +-- } +-- deriving Generic +-- +-- instance Mutable (TwoVectors 'Identity') where +-- type Ref (TwoVectors 'Identity') = TwoVectors ('RefFor' m) +-- @ +-- +-- And now your mutable ref is literally going to be a product of the +-- components +-- +-- @ +-- ghci> tvr@(TV is ds) <- thawRef (TV xs ys) +-- ghci> :t tvr +-- TV ('RefFor' IO) +-- ghci> :t is +-- 'MV.MVector' RealWorld Int +-- ghci> :t ds +-- 'MV.MVector' RealWorld Double +-- @ +-- +-- So 'thawRef' will actually just get you the same record type but with +-- the mutable versions of each field. If you modify the mutable fields, +-- and then later 'freezeRef' the whole thing, the resulting frozen value +-- will incorporate all of the changes to the individual fields. +-- +-- In addition, there are a few more "automatically derived" instances you +-- can get by picking 'Ref': +-- +-- @ +-- -- Make a mutable version for any newtype wrapper, using the 'Mutable' +-- -- of the underlying type +-- newtype MyType = MT (Vector Double) +-- +-- type Ref m MyType = CoerceRef m MyType (Vector Double) +-- +-- -- Make a mutable version of any container, where the items are all +-- -- mutable references. +-- data MyContainer a = MC a a a a +-- deriving (Functor, Foldable, Traversable) +-- +-- type Ref m (MyContainer a) = TraverseRef m MyContainer a +-- @ +-- +-- See for more +-- information on this typeclass and how to define instances +-- automatically. +class Monad m => Mutable m a where + -- | Links the type @a@ to the type of its canonical "mutable version". + -- + -- For example, for 'V.Vector', the mutable version is 'MV.MVector', so + -- we have + -- + -- @ + -- type Ref m ('V.Vector' a) = 'MV.MVector' ('PrimState' m) a + -- @ + -- + -- This means that using 'thawRef' on a 'V.Vector' will give you an + -- 'MV.MVector', using 'freezeRef' on a 'MV.Vector' will give you + -- a 'V.Vector', etc. + -- + -- @ + -- 'thawRef' + -- :: ('PrimMonad' m, s ~ 'PrimState' m) + -- => 'V.Vector' a + -- -> m ('MV.Vector' s a) + -- + -- 'freezeRef' + -- :: ('PrimMonad' m, s ~ 'PrimState' m) + -- => 'MV.Vector' s a + -- -> m ('V.Vector' a) + -- + -- 'copyRef' + -- :: ('PrimMonad' m, s ~ 'PrimState' m) + -- => 'MV.Vector' s a + -- -> 'V.Vector' a + -- -> m () + -- @ + -- + -- This associated type must be unique for @a@, so no two types @a@ can + -- have the same @'Ref' m a@. This makes type inference a lot more + -- useful: if you use 'freezeRef' on an 'MV.MVector', for instance, the + -- return type will be inferred to be 'V.Vector'. + -- + -- The /default/ instance is just a plain old 'MutVar' containing the + -- type. This is a valid instance, but it treats the entire type + -- "wholesale" --- it is basically using it as a non-mutable type. You + -- won't get any of the performance benefits of piecewise mutation from + -- it, but it is useful as a base case for non-composite types like + -- 'Int'. + -- + -- There are some built-in alternative options for user-defined ADTs + -- with 'Generic' instances: + -- + -- @ + -- -- Works for all 'Generic' instances, preserves piecewise mutation + -- -- for products + -- type Ref m a = 'GRef' m a + -- @ + -- + -- If you just set up a blank instance, the implementations of + -- 'thawRef', 'freezeRef', and 'copyRef' will be inferred using + -- 'DefaultMutable'. + -- + -- @ + -- data MyType + -- + -- -- The default setup is OK + -- instance Mutable m MyType + -- + -- -- This is equivalent to the above + -- instance Mutable m MyType + -- type Ref m MyType = 'MutVar' ('PrimState' m) MyType + -- + -- -- any 'Generic' instance + -- data MyType = MyType { mtInt :: Int, mtDouble :: Double } + -- deriving Generic + -- + -- instance Mutable m MyType where + -- type Ref m MyType = 'GRef' m MyType + -- @ + -- + -- See for more + -- information on this type family and how to define instances + -- automatically. + type Ref m a = (v :: Type) | v -> a + type Ref m a = MutVar (PrimState m) a + + -- | "Thaw" a pure/persistent value into its mutable version, which can + -- be manipulated using 'Data.Mutable.modifyRef' or other methods + -- specific for that type (like 'MV.read'). + -- + -- Returns the 'Ref' instance, so, for example, for 'V.Vector': + -- + -- @ + -- 'thawRef' + -- :: ('PrimMonad' m, s ~ 'PrimState' m) + -- => 'V.Vector' a + -- -> m ('MV.Vector' s a) + -- @ + -- + -- For non-composite (like 'Int'), this is often called the "new var" + -- function, like 'Data.IORef.newIORef' / 'Data.STRef.newSTRef' + -- / 'newMutVar' etc. + thawRef :: a -> m (Ref m a) + + -- | "Freeze" a mutable value into its pure/persistent version. + -- + -- Takes a 'Ref' instance, but type inference will be able to infer the + -- pure value's type because 'Ref' is injective. + -- + -- For example, for 'V.Vector': + -- + -- @ + -- 'freezeRef' + -- :: ('PrimMonad' m, s ~ 'PrimState' m) + -- => 'MV.Vector' s a + -- -> m ('V.Vector' a) + -- @ + -- + -- For non-composite (like 'Int'), this is often called the "read var" + -- function, like 'Data.IORef.readIORef' / 'Data.STRef.readSTRef' + -- / 'readMutVar' etc. + freezeRef :: Ref m a -> m a + + -- | Overwrite a mutable value by provivding a pure/persistent value. + -- 'copyRef' + -- + -- Returns the 'Ref' and the value, so, for example, for 'V.Vector': + -- + -- @ + -- 'copyRef' + -- :: ('PrimMonad' m, s ~ 'PrimState' m) + -- => 'MV.Vector' s a + -- -> 'V.Vector' a + -- -> m () + -- @ + -- + -- Note that if @a@ is a composite type (with an appropriate composite + -- reference), this will be done "piecewise": it'll write to each + -- mutable component separately. + -- + -- For non-composite (like 'Int'), this is often called the "write var" + -- function, like 'Data.IORef.writeIORef' / 'Data.STRef.writeSTRef' + -- / 'writeMutVar' etc. + copyRef + :: Ref m a -- ^ destination to overwrite + -> a -- ^ value + -> m () + + -- | Deep Copy-move a mutable reference on top of another, overwriting the + -- second one. + -- + -- For non-composite types, this is the same as a 'thawRef' and + -- a 'copyRef'. For composite types this can be more effficient + -- because the copying is done piecewise, so the intermediate pure value + -- is never created. + moveRef + :: Ref m a -- ^ destination + -> Ref m a -- ^ source + -> m () + + -- | Create a deep copy of a mutable reference, allocated to a separate + -- independent reference. + -- + -- For non-composite types, this is the same as a 'thawRef' and + -- a 'freezeRef'. For composite types this can be more effficient + -- because the cloning is done piecewise, so the intermediate pure value + -- is never created. + cloneRef :: Ref m a -> m (Ref m a) + + -- this is nice but you can't write an instance for 'TraverseRef' on + -- this, so maybe not. + -- -- | Initialize a mutable reference with fields being undefined or + -- -- with undefined values. This is only useful if you can modify parts + -- -- of the mutable value (with things like "Data.Mutable.Parts"). If + -- -- you attempt to 'freezeRef' (or 'modifyRef' etc.) this before setting + -- -- all of the fields to reasonable values, this is likely to blow up. + -- initRef :: m (Ref m a) + + -- | A non-copying version of 'thawRef' that can be more efficient for + -- types where the mutable representation is the same as the immutable + -- one (like 'V.Vector'). + -- + -- This is safe as long as you never again use the original pure + -- value, since it can potentially directly mutate it. + unsafeThawRef :: a -> m (Ref m a) + + -- | A non-copying version of 'freezeRef' that can be more efficient for + -- types where the mutable representation is the same as the immutable + -- one (like 'V.Vector'). + -- + -- This is safe as long as you never again modify the mutable + -- reference, since it can potentially directly mutate the frozen value + -- magically. + unsafeFreezeRef :: Ref m a -> m a + + default thawRef :: DefaultMutable m a (Ref m a) => a -> m (Ref m a) + thawRef = defaultThawRef + default freezeRef :: DefaultMutable m a (Ref m a) => Ref m a -> m a + freezeRef = defaultFreezeRef + default copyRef :: DefaultMutable m a (Ref m a) => Ref m a -> a -> m () + copyRef = defaultCopyRef + default moveRef :: DefaultMutable m a (Ref m a) => Ref m a -> Ref m a -> m () + moveRef = defaultMoveRef + default cloneRef :: DefaultMutable m a (Ref m a) => Ref m a -> m (Ref m a) + cloneRef = defaultCloneRef + default unsafeThawRef :: DefaultMutable m a (Ref m a) => a -> m (Ref m a) + unsafeThawRef = defaultUnsafeThawRef + default unsafeFreezeRef :: DefaultMutable m a (Ref m a) => Ref m a -> m a + unsafeFreezeRef = defaultUnsafeFreezeRef + +-- | The default implementations of 'thawRef', 'freezeRef', and 'copyRef' +-- dispatched for different choices of 'Ref'. +-- +-- Basically, by specifying 'Ref', you get the rest of the instance for +-- free. +-- +-- We have the default case: +-- +-- @ +-- -- default, if you don't specify 'Ref' +-- instance Mutable m MyType +-- +-- -- the above is the same as: +-- instance Mutable m MyType +-- type Ref m MyType = MutVar (PrimState m) MyType +-- @ +-- +-- The case for any instance of 'Generic': +-- +-- @ +-- instance Mutable m MyType +-- type Ref m MyType = GRef m MyType +-- @ +-- +-- The case for the "higher-kinded data" pattern a la +-- : +-- +-- @ +-- instance Mutable m (MyTypeF Identity) +-- type Ref m (MyTypeF Identity) = MyTypeF (RefFor m) +-- @ +-- +-- The case for any newtype wrapper: +-- +-- @ +-- newtype MyType = MT (Vector Double) +-- +-- instance Mutable m MyType where +-- type Ref m MyType = CoerceRef m MyType (Vector Double) +-- @ +-- +-- And the case for any 'Traversable instance, where the items will all be +-- mutable references: +-- +-- @ +-- data MyContainer a = MC a a a a +-- deriving (Functor, Foldable, Traversable) +-- +-- instance Mutable m a => Mutable m (MyContainer a) where +-- type Ref m (MyContainer a) = TraverseRef m MyContainer a +-- @ +-- +class DefaultMutable m a r | r -> a where + defaultThawRef :: a -> m r + defaultFreezeRef :: r -> m a + defaultCopyRef :: r -> a -> m () + defaultMoveRef :: r -> r -> m () + defaultCloneRef :: r -> m r + defaultUnsafeThawRef :: a -> m r + defaultUnsafeFreezeRef :: r -> m a + +instance (PrimMonad m, s ~ PrimState m) => DefaultMutable m a (MutVar s a) where + defaultThawRef = newMutVar + defaultFreezeRef = readMutVar + defaultCopyRef = writeMutVar + defaultMoveRef v u = writeMutVar v =<< readMutVar u + defaultCloneRef v = newMutVar =<< readMutVar v + defaultUnsafeThawRef = newMutVar + defaultUnsafeFreezeRef = readMutVar + +instance (Generic a, GMutable m (Rep a)) => DefaultMutable m a (GRef m a) where + defaultThawRef = gThawRef + defaultFreezeRef = gFreezeRef + defaultCopyRef = gCopyRef + defaultMoveRef = gMoveRef + defaultCloneRef = gCloneRef + defaultUnsafeThawRef = gUnsafeThawRef + defaultUnsafeFreezeRef = gUnsafeFreezeRef + +instance (Generic (z Identity), Generic (z (RefFor m)), GMutable m (Rep (z Identity)), GRef_ m (Rep (z Identity)) ~ Rep (z (RefFor m))) + => DefaultMutable m (z Identity) (z (RefFor m)) where + defaultThawRef = thawHKD + defaultFreezeRef = freezeHKD + defaultCopyRef = copyHKD + defaultMoveRef = moveHKD + defaultCloneRef = cloneHKD + defaultUnsafeThawRef = unsafeThawHKD + defaultUnsafeFreezeRef = unsafeFreezeHKD + +instance (Traversable f, Mutable m a) => DefaultMutable m (f a) (TraverseRef m f a) where + defaultThawRef = thawTraverse + defaultFreezeRef = freezeTraverse + defaultCopyRef = copyTraverse + defaultMoveRef = moveTraverse + defaultCloneRef = cloneTraverse + defaultUnsafeThawRef = unsafeThawTraverse + defaultUnsafeFreezeRef = unsafeFreezeTraverse + +instance (Coercible s a, Mutable m a) => DefaultMutable m s (CoerceRef m s a) where + defaultThawRef = thawCoerce + defaultFreezeRef = freezeCoerce + defaultCopyRef = copyCoerce + defaultMoveRef = moveCoerce + defaultCloneRef = cloneCoerce + defaultUnsafeThawRef = unsafeThawCoerce + defaultUnsafeFreezeRef = unsafeFreezeCoerce + +instance Applicative m => DefaultMutable m a (ImmutableRef a) where + defaultThawRef = thawImmutable + defaultFreezeRef = freezeImmutable + defaultCopyRef = copyImmutable + defaultMoveRef = moveImmutable + defaultCloneRef = cloneImmutable + defaultUnsafeThawRef = thawImmutable + defaultUnsafeFreezeRef = freezeImmutable + +-- | A handy newtype wrapper that allows you to partially apply 'Ref'. +-- @'RefFor' m a@ is the same as @'Ref' m a@, but can be partially applied. +-- +-- If used with 'X.HKD', you can treat this syntactically identically as +-- a @'Ref' m a@. +newtype RefFor m a = RefFor { getRefFor :: Ref m a } + +deriving instance Eq (Ref m a) => Eq (RefFor m a) +deriving instance Ord (Ref m a) => Ord (RefFor m a) + +-- | Use a @'RefFor' m a@ as if it were a @'Ref' m a@. +instance X.IsoHKD (RefFor m) a where + type HKD (RefFor m) a = Ref m a + unHKD = RefFor + toHKD = getRefFor + +-- | A 'Ref' that works for any instance of 'Traversable', by using the +-- fields of the 'Traversable' instance to /purely/ store mutable references. +-- +-- Note that this really only makes complete sense if the 'Traversable' is +-- fixed-size, or you never modify the length of the traversable as you use +-- it as a reference. +-- +-- If you /do/ modify the length, copying and modifying semantics can be +-- a bit funky: +-- +-- * If copying a shorter item into a longer item ref, the "leftovers" items +-- in the longer item are unchanged. +-- * If copying a longer item into a shorter item ref, the leftover items +-- are unchanged. +-- +-- @ +-- ghci> r <- 'thawTraverse' [1..10] +-- ghci> 'copyTraverse' r [0,0,0,0] +-- ghci> 'freezeTraverse' r +-- [0,0,0,0,5,6,7,8,9,10] +-- ghci> 'copyTraverse' r [20..50] +-- ghci> 'freezeTraverse' r +-- [20,21,22,23,24,25,26,27,28,29] +-- @ +-- +newtype TraverseRef m f a = TraverseRef { getTraverseRef :: f (Ref m a) } + +-- | Use a @'TraverseRef' m f a@ as if it were a @f ('Ref' m a)@ +instance X.IsoHKD (TraverseRef m f) a where + type HKD (TraverseRef m f) a = f (Ref m a) + unHKD = TraverseRef + toHKD = getTraverseRef + +-- | Default 'thawRef' for 'TraverseRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'TraverseRef' as the +-- 'Ref'. However, it can be useful if you are using a @'TraverseRef' +-- m f a@ just as a normal data type, independent of the 'Ref' class. See +-- documentation for 'TraverseRef' for more information. +thawTraverse :: (Traversable f, Mutable m a) => f a -> m (TraverseRef m f a) +thawTraverse = fmap TraverseRef . traverse thawRef + +-- | Default 'freezeRef' for 'TraverseRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'TraverseRef' as the +-- 'Ref'. However, it can be useful if you are using a @'TraverseRef' +-- m f a@ just as a normal data type, independent of the 'Ref' class. See +-- documentation for 'TraverseRef' for more information. +freezeTraverse :: (Traversable f, Mutable m a) => TraverseRef m f a -> m (f a) +freezeTraverse = traverse freezeRef . getTraverseRef + +-- | Default 'copyRef' for 'TraverseRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'TraverseRef' as the +-- 'Ref'. However, it can be useful if you are using a @'TraverseRef' +-- m f a@ just as a normal data type, independent of the 'Ref' class. See +-- documentation for 'TraverseRef' for more information. +copyTraverse :: (Traversable f, Mutable m a) => TraverseRef m f a -> f a -> m () +copyTraverse (TraverseRef rs) xs = evalStateT (traverse_ go rs) (toList xs) + where + go r = do + x <- state $ maybe (Nothing, []) (first Just) . uncons + lift $ mapM_ (copyRef r) x + +-- | Default 'moveRef' for 'TraverseRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'TraverseRef' as the +-- 'Ref'. However, it can be useful if you are using a @'TraverseRef' +-- m f a@ just as a normal data type, independent of the 'Ref' class. See +-- documentation for 'TraverseRef' for more information. +moveTraverse + :: (Traversable f, Mutable m a) + => TraverseRef m f a -- ^ destination + -> TraverseRef m f a -- ^ source + -> m () +moveTraverse (TraverseRef rs) (TraverseRef vs) = evalStateT (traverse_ go rs) (toList vs) + where + go r = do + x <- state $ maybe (Nothing, []) (first Just) . uncons + lift $ mapM_ (moveRef r) x + +-- | Default 'cloneRef' for 'TraverseRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'TraverseRef' as the +-- 'Ref'. However, it can be useful if you are using a @'TraverseRef' +-- m f a@ just as a normal data type, independent of the 'Ref' class. See +-- documentation for 'TraverseRef' for more information. +cloneTraverse :: (Traversable f, Mutable m a) => TraverseRef m f a -> m (TraverseRef m f a) +cloneTraverse = fmap TraverseRef . traverse cloneRef . getTraverseRef + +-- | Default 'unsafeThawRef' for 'TraverseRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'TraverseRef' as the +-- 'Ref'. However, it can be useful if you are using a @'TraverseRef' +-- m f a@ just as a normal data type, independent of the 'Ref' class. See +-- documentation for 'TraverseRef' for more information. +unsafeThawTraverse :: (Traversable f, Mutable m a) => f a -> m (TraverseRef m f a) +unsafeThawTraverse = fmap TraverseRef . traverse unsafeThawRef + +-- | Default 'unsafeFreezeRef' for 'TraverseRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'TraverseRef' as the +-- 'Ref'. However, it can be useful if you are using a @'TraverseRef' +-- m f a@ just as a normal data type, independent of the 'Ref' class. See +-- documentation for 'TraverseRef' for more information. +unsafeFreezeTraverse :: (Traversable f, Mutable m a) => TraverseRef m f a -> m (f a) +unsafeFreezeTraverse = traverse unsafeFreezeRef . getTraverseRef + +-- | A 'Ref' that works by using the 'Mutable' instance of an equivalent +-- type. This is useful for newtype wrappers, so you can use the +-- underlying data type's 'Mutable' instance. +-- +-- @ +-- newtype MyVec = MyVec ('V.Vector' Double) +-- +-- instance 'Mutable' m MyVec where +-- type 'Ref' m MyVec = 'CoerceRef' m s ('V.Vector' Double) +-- @ +-- +-- The @Ref m MyVec@ uses the a @'MV.MVector' Double@ under the hood. +-- +-- It's essentially a special case of 'GRef' for newtypes. +newtype CoerceRef m s a = CoerceRef { getCoerceRef :: Ref m a } + +deriving instance Eq (Ref m a) => Eq (CoerceRef m s a) +deriving instance Ord (Ref m a) => Ord (CoerceRef m s a) + +-- | Use a @'CoerceRef' m s a@ as if it were a @'Ref' m a@ +instance X.IsoHKD (CoerceRef m s) a where + type HKD (CoerceRef m s) a = Ref m a + unHKD = CoerceRef + toHKD = getCoerceRef + +-- | Default 'thawRef' for 'CoerceRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'CoerceRef' as the 'Ref'. +-- However, it can be useful if you are using a @'CoerceRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'CoerceRef' for more information. +thawCoerce :: (Coercible s a, Mutable m a) => s -> m (CoerceRef m s a) +thawCoerce = fmap CoerceRef . thawRef . coerce + +-- | Default 'freezeRef' for 'CoerceRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'CoerceRef' as the 'Ref'. +-- However, it can be useful if you are using a @'CoerceRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'CoerceRef' for more information. +freezeCoerce :: (Coercible s a, Mutable m a) => CoerceRef m s a -> m s +freezeCoerce = fmap coerce . freezeRef . getCoerceRef + +-- | Default 'copyRef' for 'CoerceRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'CoerceRef' as the 'Ref'. +-- However, it can be useful if you are using a @'CoerceRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'CoerceRef' for more information. +copyCoerce :: (Coercible s a, Mutable m a) => CoerceRef m s a -> s -> m () +copyCoerce (CoerceRef r) = copyRef r . coerce + +-- | Default 'moveRef' for 'CoerceRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'CoerceRef' as the 'Ref'. +-- However, it can be useful if you are using a @'CoerceRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'CoerceRef' for more information. +moveCoerce :: Mutable m a => CoerceRef m s a -> CoerceRef m s a -> m () +moveCoerce (CoerceRef r) (CoerceRef s) = moveRef r s + +-- | Default 'cloneRef' for 'CoerceRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'CoerceRef' as the 'Ref'. +-- However, it can be useful if you are using a @'CoerceRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'CoerceRef' for more information. +cloneCoerce :: Mutable m a => CoerceRef m s a -> m (CoerceRef m s a) +cloneCoerce = fmap CoerceRef . cloneRef . getCoerceRef + +-- | Default 'unsafeThawRef' for 'CoerceRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'CoerceRef' as the 'Ref'. +-- However, it can be useful if you are using a @'CoerceRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'CoerceRef' for more information. +unsafeThawCoerce :: (Coercible s a, Mutable m a) => s -> m (CoerceRef m s a) +unsafeThawCoerce = fmap CoerceRef . unsafeThawRef . coerce + +-- | Default 'unsafeFreezeRef' for 'CoerceRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'CoerceRef' as the 'Ref'. +-- However, it can be useful if you are using a @'CoerceRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'CoerceRef' for more information. +unsafeFreezeCoerce :: (Coercible s a, Mutable m a) => CoerceRef m s a -> m s +unsafeFreezeCoerce = fmap coerce . unsafeFreezeRef . getCoerceRef + +-- | A "'Ref'" that can be used to give a default 'Mutable' instance that +-- is immutable. Nothing is allocated ever, all attempts to modify it will +-- be ignored, and 'freezeRef' will just get the original thawed value. +-- +-- Really only exists to be used with 'Data.Mutable.Class.Immutable'. +newtype ImmutableRef a = ImmutableRef { getImmutableRef :: a } + +-- | Use a @'ImmutableRef' a@ as if it were an @a@ +instance X.IsoHKD ImmutableRef a where + type HKD ImmutableRef a = a + unHKD = ImmutableRef + toHKD = getImmutableRef + +-- | Default 'thawRef' for 'ImmutableRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'ImmutableRef' as the 'Ref'. +-- However, it can be useful if you are using a @'ImmutableRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'ImmutableRef' for more information. +thawImmutable :: Applicative m => a -> m (ImmutableRef a) +thawImmutable = pure . ImmutableRef + +-- | Default 'freezeRef' for 'ImmutableRef'. This will always return the +-- originally thawed value, ignoring all copies and writes. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'ImmutableRef' as the 'Ref'. +-- However, it can be useful if you are using a @'ImmutableRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'ImmutableRef' for more information. +freezeImmutable :: Applicative m => ImmutableRef a -> m a +freezeImmutable = pure . getImmutableRef + +-- | Default 'copyRef' for 'ImmutableRef'. This is a no-op and does +-- nothing, since freezing will always return the originally thawed value. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'ImmutableRef' as the 'Ref'. +-- However, it can be useful if you are using a @'ImmutableRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'ImmutableRef' for more information. +copyImmutable :: Applicative m => ImmutableRef a -> a -> m () +copyImmutable _ _ = pure () + +-- | Default 'moveRef' for 'ImmutableRef'. This is a no-op and does +-- nothing, since freezing will always return the originally thawed value. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'ImmutableRef' as the 'Ref'. +-- However, it can be useful if you are using a @'ImmutableRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'ImmutableRef' for more information. +moveImmutable :: Applicative m => ImmutableRef a -> ImmutableRef a -> m () +moveImmutable _ _ = pure () + +-- | Default 'cloneRef' for 'ImmutableRef'. 'freezeRef' on this value will +-- return the originally thawed value. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'ImmutableRef' as the 'Ref'. +-- However, it can be useful if you are using a @'ImmutableRef' m s a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'ImmutableRef' for more information. +cloneImmutable :: Applicative m => ImmutableRef a -> m (ImmutableRef a) +cloneImmutable = pure + + + +-- | Class for automatic generation of 'Ref' for 'Generic' instances. See +-- 'GRef' for more information. +class Monad m => GMutable m f where + type GRef_ m f = (u :: k -> Type) | u -> f + + gThawRef_ :: f a -> m (GRef_ m f a) + gFreezeRef_ :: GRef_ m f a -> m (f a) + gCopyRef_ :: GRef_ m f a -> f a -> m () + gMoveRef_ :: GRef_ m f a -> GRef_ m f a -> m () + gCloneRef_ :: GRef_ m f a -> m (GRef_ m f a) + gUnsafeThawRef_ :: f a -> m (GRef_ m f a) + gUnsafeFreezeRef_ :: GRef_ m f a -> m (f a) + +instance Mutable m c => GMutable m (K1 i c) where + type GRef_ m (K1 i c) = K1 i (Ref m c) + + gThawRef_ = fmap K1 . thawRef . unK1 + gFreezeRef_ = fmap K1 . freezeRef . unK1 + gCopyRef_ (K1 v) (K1 x) = copyRef v x + gMoveRef_ (K1 v) (K1 u) = moveRef v u + gCloneRef_ = fmap K1 . cloneRef . unK1 + gUnsafeThawRef_ = fmap K1 . unsafeThawRef . unK1 + gUnsafeFreezeRef_ = fmap K1 . unsafeFreezeRef . unK1 + +instance Monad m => GMutable m U1 where + type GRef_ m U1 = U1 + + gThawRef_ _ = pure U1 + gFreezeRef_ _ = pure U1 + gCopyRef_ _ _ = pure () + gMoveRef_ _ _ = pure () + gCloneRef_ _ = pure U1 + gUnsafeThawRef_ _ = pure U1 + gUnsafeFreezeRef_ _ = pure U1 + +instance Monad m => GMutable m V1 where + type GRef_ m V1 = V1 + + gThawRef_ = \case {} + gFreezeRef_ = \case {} + gCopyRef_ = \case {} + gMoveRef_ = \case {} + gCloneRef_ = \case {} + gUnsafeThawRef_ = \case {} + gUnsafeFreezeRef_ = \case {} + +instance (GMutable m f, GMutable m g) => GMutable m (f :*: g) where + type GRef_ m (f :*: g) = GRef_ m f :*: GRef_ m g + + gThawRef_ (x :*: y) = (:*:) <$> gThawRef_ x <*> gThawRef_ y + gFreezeRef_ (v :*: u) = (:*:) <$> gFreezeRef_ v <*> gFreezeRef_ u + gCopyRef_ (v :*: u) (x :*: y) = gCopyRef_ v x *> gCopyRef_ u y + gMoveRef_ (v :*: u) (v' :*: u') = gMoveRef_ v v' *> gMoveRef_ u u' + gCloneRef_ (v :*: u) = (:*:) <$> gCloneRef_ v <*> gCloneRef_ u + gUnsafeThawRef_ (x :*: y) = (:*:) <$> gUnsafeThawRef_ x <*> gUnsafeThawRef_ y + gUnsafeFreezeRef_ (v :*: u) = (:*:) <$> gUnsafeFreezeRef_ v <*> gUnsafeFreezeRef_ u + +instance GMutable m f => GMutable m (M1 i c f) where + type GRef_ m (M1 i c f) = M1 i c (GRef_ m f) + + gThawRef_ = fmap M1 . gThawRef_ . unM1 + gFreezeRef_ = fmap M1 . gFreezeRef_ . unM1 + gCopyRef_ (M1 v) (M1 x) = gCopyRef_ v x + gMoveRef_ (M1 v) (M1 u) = gMoveRef_ v u + gCloneRef_ (M1 v) = M1 <$> gCloneRef_ v + gUnsafeThawRef_ = fmap M1 . gUnsafeThawRef_ . unM1 + gUnsafeFreezeRef_ = fmap M1 . gUnsafeFreezeRef_ . unM1 + +-- | Wraps ':+:' in a mutable reference. Used internally to represent +-- generic sum references. +newtype MutSumF m f g a = MutSumF { getMutSumF :: MutVar (PrimState m) ((f :+: g) a) } + +instance (GMutable m f, GMutable m g, PrimMonad m) => GMutable m (f :+: g) where + type GRef_ m (f :+: g) = MutSumF m (GRef_ m f) (GRef_ m g) + -- MutVar (PrimState m) :.: (GRef_ m f :+: GRef_ m g) + + gThawRef_ = \case + L1 x -> fmap MutSumF . newMutVar . L1 =<< gThawRef_ x + R1 x -> fmap MutSumF . newMutVar . R1 =<< gThawRef_ x + gFreezeRef_ (MutSumF r) = readMutVar r >>= \case + L1 v -> L1 <$> gFreezeRef_ v + R1 u -> R1 <$> gFreezeRef_ u + gCopyRef_ (MutSumF r) xy = readMutVar r >>= \case + L1 v -> case xy of + L1 x -> gCopyRef_ v x + R1 y -> writeMutVar r . R1 =<< gThawRef_ y + R1 u -> case xy of + L1 x -> writeMutVar r . L1 =<< gThawRef_ x + R1 y -> gCopyRef_ u y + gMoveRef_ (MutSumF u) (MutSumF v) = readMutVar v >>= \case + L1 vl -> readMutVar u >>= \case + L1 ul -> gMoveRef_ ul vl + R1 _ -> writeMutVar u . L1 =<< gCloneRef_ vl + R1 vr -> readMutVar u >>= \case + L1 _ -> writeMutVar u . R1 =<< gCloneRef_ vr + R1 ur -> gMoveRef_ ur vr + gCloneRef_ (MutSumF v) = readMutVar v >>= \case + L1 u -> fmap MutSumF . newMutVar . L1 =<< gCloneRef_ u + R1 u -> fmap MutSumF . newMutVar . R1 =<< gCloneRef_ u + gUnsafeThawRef_ = \case + L1 x -> fmap MutSumF . newMutVar . L1 =<< gUnsafeThawRef_ x + R1 x -> fmap MutSumF . newMutVar . R1 =<< gUnsafeThawRef_ x + gUnsafeFreezeRef_ (MutSumF r) = readMutVar r >>= \case + L1 v -> L1 <$> gUnsafeFreezeRef_ v + R1 u -> R1 <$> gUnsafeFreezeRef_ u + + +-- | A 'Ref' for instances of 'GMutable', which are the "GHC.Generics" +-- combinators. +newtype GMutableRef m f a = GMutableRef { getGMutableRef :: GRef_ m f a } + +deriving instance Eq (GRef_ m f a) => Eq (GMutableRef m f a) +deriving instance Ord (GRef_ m f a) => Ord (GMutableRef m f a) + +thawGMutableRef :: GMutable m f => f a -> m (GMutableRef m f a) +thawGMutableRef = fmap GMutableRef . gThawRef_ + +freezeGMutableRef :: GMutable m f => GMutableRef m f a -> m (f a) +freezeGMutableRef = gFreezeRef_ . getGMutableRef + +copyGMutableRef :: GMutable m f => GMutableRef m f a -> f a -> m () +copyGMutableRef (GMutableRef r) = gCopyRef_ r + +moveGMutableRef :: GMutable m f => GMutableRef m f a -> GMutableRef m f a -> m () +moveGMutableRef (GMutableRef r) (GMutableRef s) = gMoveRef_ r s + +cloneGMutableRef :: GMutable m f => GMutableRef m f a -> m (GMutableRef m f a) +cloneGMutableRef (GMutableRef r) = GMutableRef <$> gCloneRef_ r + +unsafeThawGMutableRef :: GMutable m f => f a -> m (GMutableRef m f a) +unsafeThawGMutableRef = fmap GMutableRef . gUnsafeThawRef_ + +unsafeFreezeGMutableRef :: GMutable m f => GMutableRef m f a -> m (f a) +unsafeFreezeGMutableRef = gUnsafeFreezeRef_ . getGMutableRef + +instance Mutable m c => Mutable m (K1 i c a) where + type Ref m (K1 i c a) = GMutableRef m (K1 i c) a + thawRef = thawGMutableRef + freezeRef = freezeGMutableRef + copyRef = copyGMutableRef + moveRef = moveGMutableRef + cloneRef = cloneGMutableRef + unsafeThawRef = unsafeThawGMutableRef + unsafeFreezeRef = unsafeFreezeGMutableRef + +instance Monad m => Mutable m (U1 a) where + type Ref m (U1 a) = GMutableRef m U1 a + thawRef = thawGMutableRef + freezeRef = freezeGMutableRef + copyRef = copyGMutableRef + moveRef = moveGMutableRef + cloneRef = cloneGMutableRef + unsafeThawRef = unsafeThawGMutableRef + unsafeFreezeRef = unsafeFreezeGMutableRef + +instance Monad m => Mutable m (V1 a) where + type Ref m (V1 a) = GMutableRef m V1 a + thawRef = thawGMutableRef + freezeRef = freezeGMutableRef + copyRef = copyGMutableRef + moveRef = moveGMutableRef + cloneRef = cloneGMutableRef + unsafeThawRef = unsafeThawGMutableRef + unsafeFreezeRef = unsafeFreezeGMutableRef + +instance (GMutable m f, GMutable m g) => Mutable m ((f :*: g) a) where + type Ref m ((f :*: g) a) = GMutableRef m (f :*: g) a + thawRef = thawGMutableRef + freezeRef = freezeGMutableRef + copyRef = copyGMutableRef + moveRef = moveGMutableRef + cloneRef = cloneGMutableRef + unsafeThawRef = unsafeThawGMutableRef + unsafeFreezeRef = unsafeFreezeGMutableRef + +instance (GMutable m f, GMutable m g, PrimMonad m) => Mutable m ((f :+: g) a) where + type Ref m ((f :+: g) a) = GMutableRef m (f :+: g) a + thawRef = thawGMutableRef + freezeRef = freezeGMutableRef + copyRef = copyGMutableRef + moveRef = moveGMutableRef + cloneRef = cloneGMutableRef + unsafeThawRef = unsafeThawGMutableRef + unsafeFreezeRef = unsafeFreezeGMutableRef + + +-- | Automatically generate a piecewise mutable reference for any 'Generic' +-- instance. +-- +-- @ +-- -- | any 'Generic' instance +-- data MyType = MyType { mtInt :: Int, mtDouble :: Double } +-- deriving (Generic, Show) +-- +-- instance Mutable m MyType where +-- type Ref m MyType = 'GRef' m MyType +-- @ +-- +-- @ +-- ghci> r <- 'thawRef' (MyType 3 4.5) +-- ghci> 'freezeRef' r +-- MyType 3 4.5 +-- ghci> 'Data.Mutable.Parts.freezePart' ('Data.Mutable.Parts.fieldMut' #mtInt) r +-- 3 +-- ghci> 'Data.Mutable.Parts.copyPart' (fieldMut #mtDouble) 1.23 +-- ghci> freezeRef r +-- MyType 3 1.23 +-- @ +-- +-- Note that this is basically just a bunch of tupled refs for a product +-- type. For a sum type (with multiple constructors), an extra layer of +-- indirection is added to account for the dynamically changable shape. +-- +-- See "Data.Mutable.Parts" and "Data.Mutable.Branches" for nice ways to +-- inspect and mutate the internals of this type (as demonstrated above). +-- +-- If the facilities in those modules are not adequate, you can also +-- manually crack open 'GRef' and work with the internals. Getting the +-- /type/ of @'unGRef' \@MyType@ should allow you to navigate what is going +-- on, if you are familiar with "GHC.Generics". However, ideally, you +-- would never need to do this. +newtype GRef m a = GRef { unGRef :: GRef_ m (Rep a) () } + +deriving instance Eq (GRef_ m (Rep a) ()) => Eq (GRef m a) +deriving instance Ord (GRef_ m (Rep a) ()) => Ord (GRef m a) + +-- | Default 'thawRef' for 'GRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'GRef' as the 'Ref'. +-- However, it can be useful if you are using a @'GRef' m a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'GRef' for more information. +gThawRef + :: (Generic a, GMutable m (Rep a)) + => a + -> m (GRef m a) +gThawRef = fmap GRef . gThawRef_ . from + +-- | Default 'freezeRef' for 'GRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'GRef' as the 'Ref'. +-- However, it can be useful if you are using a @'GRef' m a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'GRef' for more information. +gFreezeRef + :: (Generic a, GMutable m (Rep a)) + => GRef m a + -> m a +gFreezeRef = fmap to . gFreezeRef_ . unGRef + +-- | Default 'copyRef' for 'GRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'GRef' as the 'Ref'. +-- However, it can be useful if you are using a @'GRef' m a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'GRef' for more information. +gCopyRef + :: (Generic a, GMutable m (Rep a)) + => GRef m a + -> a + -> m () +gCopyRef (GRef v) x = gCopyRef_ v (from x) + +-- | Default 'moveRef' for 'GRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'GRef' as the 'Ref'. +-- However, it can be useful if you are using a @'GRef' m a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'GRef' for more information. +gMoveRef + :: GMutable m (Rep a) + => GRef m a + -> GRef m a + -> m () +gMoveRef (GRef v) (GRef u) = gMoveRef_ v u + +-- | Default 'cloneRef' for 'GRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'GRef' as the 'Ref'. +-- However, it can be useful if you are using a @'GRef' m a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'GRef' for more information. +gCloneRef + :: GMutable m (Rep a) + => GRef m a + -> m (GRef m a) +gCloneRef (GRef v) = GRef <$> gCloneRef_ v + +-- | Default 'unsafeThawRef' for 'GRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'GRef' as the 'Ref'. +-- However, it can be useful if you are using a @'GRef' m a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'GRef' for more information. +gUnsafeThawRef + :: (Generic a, GMutable m (Rep a)) + => a + -> m (GRef m a) +gUnsafeThawRef = fmap GRef . gUnsafeThawRef_ . from + +-- | Default 'unsafeFreezeRef' for 'GRef'. +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with 'GRef' as the 'Ref'. +-- However, it can be useful if you are using a @'GRef' m a@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'GRef' for more information. +gUnsafeFreezeRef + :: (Generic a, GMutable m (Rep a)) + => GRef m a + -> m a +gUnsafeFreezeRef = fmap to . gUnsafeFreezeRef_ . unGRef + + +-- | Default 'thawRef' for the higher-kinded data pattern, a la +-- . +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with @z ('RefFor' m)@ as the 'Ref'. +-- However, it can be useful if you are using a @z ('RefFor' m)@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'Mutable' for more information. +thawHKD + :: forall z m. + ( Generic (z Identity) + , Generic (z (RefFor m)) + , GMutable m (Rep (z Identity)) + , GRef_ m (Rep (z Identity)) ~ Rep (z (RefFor m)) + ) + => z Identity + -> m (z (RefFor m)) +thawHKD = fmap to . gThawRef_ . from + +-- | Default 'freezeRef' for the higher-kinded data pattern, a la +-- . +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with @z ('RefFor' m)@ as the 'Ref'. +-- However, it can be useful if you are using a @z ('RefFor' m)@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'Mutable' for more information. +freezeHKD + :: forall z m. + ( Generic (z Identity) + , Generic (z (RefFor m)) + , GMutable m (Rep (z Identity)) + , GRef_ m (Rep (z Identity)) ~ Rep (z (RefFor m)) + ) + => z (RefFor m) + -> m (z Identity) +freezeHKD = fmap to . gFreezeRef_ . from + +-- | Default 'copyRef' for the higher-kinded data pattern, a la +-- . +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with @z ('RefFor' m)@ as the 'Ref'. +-- However, it can be useful if you are using a @z ('RefFor' m)@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'Mutable' for more information. +copyHKD + :: forall z m. + ( Generic (z Identity) + , Generic (z (RefFor m)) + , GMutable m (Rep (z Identity)) + , GRef_ m (Rep (z Identity)) ~ Rep (z (RefFor m)) + ) + => z (RefFor m) + -> z Identity + -> m () +copyHKD r x = gCopyRef_ (from r) (from x) + +-- | Default 'moveRef' for the higher-kinded data pattern, a la +-- . +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with @z ('RefFor' m)@ as the 'Ref'. +-- However, it can be useful if you are using a @z ('RefFor' m)@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'Mutable' for more information. +moveHKD + :: forall z m. + ( Generic (z (RefFor m)) + , GMutable m (Rep (z Identity)) + , GRef_ m (Rep (z Identity)) ~ Rep (z (RefFor m)) + ) + => z (RefFor m) + -> z (RefFor m) + -> m () +moveHKD r x = gMoveRef_ (from r) (from x) + +-- | Default 'cloneRef' for the higher-kinded data pattern, a la +-- . +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with @z ('RefFor' m)@ as the 'Ref'. +-- However, it can be useful if you are using a @z ('RefFor' m)@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'Mutable' for more information. +cloneHKD + :: forall z m. + ( Generic (z (RefFor m)) + , GMutable m (Rep (z Identity)) + , GRef_ m (Rep (z Identity)) ~ Rep (z (RefFor m)) + ) + => z (RefFor m) + -> m (z (RefFor m)) +cloneHKD = fmap to . gCloneRef_ . from + +-- | Default 'unsafeThawRef' for the higher-kinded data pattern, a la +-- . +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with @z ('RefFor' m)@ as the 'Ref'. +-- However, it can be useful if you are using a @z ('RefFor' m)@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'Mutable' for more information. +unsafeThawHKD + :: forall z m. + ( Generic (z Identity) + , Generic (z (RefFor m)) + , GMutable m (Rep (z Identity)) + , GRef_ m (Rep (z Identity)) ~ Rep (z (RefFor m)) + ) + => z Identity + -> m (z (RefFor m)) +unsafeThawHKD = fmap to . gUnsafeThawRef_ . from + +-- | Default 'unsafeFreezeRef' for the higher-kinded data pattern, a la +-- . +-- +-- You likely won't ever use this directly, since it is automatically +-- provided if you have a 'Mutable' instance with @z ('RefFor' m)@ as the 'Ref'. +-- However, it can be useful if you are using a @z ('RefFor' m)@ just as +-- a normal data type, independent of the 'Ref' class. See documentation +-- for 'Mutable' for more information. +unsafeFreezeHKD + :: forall z m. + ( Generic (z Identity) + , Generic (z (RefFor m)) + , GMutable m (Rep (z Identity)) + , GRef_ m (Rep (z Identity)) ~ Rep (z (RefFor m)) + ) + => z (RefFor m) + -> m (z Identity) +unsafeFreezeHKD = fmap to . gUnsafeFreezeRef_ . from diff --git a/src/Data/Mutable/Parts.hs b/src/Data/Mutable/Parts.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mutable/Parts.hs @@ -0,0 +1,656 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Data.Mutable.Parts +-- Copyright : (c) Justin Le 2020 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Tools for working with individual components of piecewise-mutable +-- values. +-- +-- If "Data.Mutable.Branches" is for sum types, then "Data.Mutable.Parts" +-- is for sum types. +-- +-- See for an introduction +-- to this module. +-- +module Data.Mutable.Parts ( + MutPart(..) + , withPart + , freezePart, copyPart + , movePartInto, movePartOver, movePartWithin + , clonePart, unsafeFreezePart + , modifyPart, modifyPart' + , updatePart, updatePart' + , modifyPartM, modifyPartM' + , updatePartM, updatePartM' + -- * Built-in 'MutPart' + , compMP + , idMP + , mutFst, mutSnd + -- ** Field + , FieldMut(..), withField, mutField, Label(..) + -- ** Position + , PosMut(..), withPos, mutPos + -- ** HList + , TupleMut(..), withTuple + -- ** Other + , hkdMutParts, HKDMutParts + , mutRec + , coerceRef, withCoerceRef + , MapRef + ) where + +import Data.Coerce +import Data.Kind +import Data.Mutable.Class +import Data.Mutable.Instances +import Data.Vinyl hiding (HList) +import Data.Vinyl.Functor +import GHC.Generics +import GHC.TypeLits +import qualified Control.Category as C +import qualified Data.GenericLens.Internal as GL +import qualified Data.Generics.Internal.Profunctor.Lens as GLP +import qualified Data.Generics.Product.Fields as GL +import qualified Data.Generics.Product.Positions as GL +import qualified Data.Vinyl.TypeLevel as V +import qualified Data.Vinyl.XRec as X + + +-- | A @'MutPart' m s a@ is a way to "zoom into" an @a@, as a part of +-- a mutable reference on @s@. This allows you to only modify a single +-- @a@ part of the @s@, without touching the rest. It's spiritually +-- similar to a @Lens' s a@. +-- +-- If 'Data.Mutable.Branches.MutBranch' is for sum types, then 'MutPart' is +-- for product types. +-- +-- See for an introduction +-- to this type. +-- +-- An example that is commonly found in the ecosystem is something like +-- (flipped) @write :: Int -> 'Data.Vector.MVector' s a -> a -> m ()@ from +-- "Data.Vector.Mutable" --- @write 3 :: 'Data.Vector.MVector' s a -> a -> +-- m ()@, for instance, lets you modify a specific part of the vector +-- without touching the rest. +-- +-- You would /use/ a 'MutPart' using 'freezePart', 'copyPart', +-- 'modifyPart', etc. +-- +-- For non-composite types, there won't really be any meaningful values. +-- However, we have them for many composite types. For example, for +-- tuples: +-- +-- @ +-- 'mutFst' :: 'MutPart' m (a, b) a +-- 'mutSnd' :: MutPart m (a, b) b +-- @ +-- +-- @ +-- ghci> r <- 'thawRef' (2, 4) +-- ghci> 'copyPart' mutFst r 100 +-- ghci> 'freezeRef' r +-- (100, 4) +-- @ +-- +-- If you are using 'GRef' as an automatically-defined mutable reference, +-- then the easiest way to create these for your mutable types are with +-- 'fieldMut' and 'posMut'. +-- +-- If you are using the "Higher-kinded data" pattern, then there's an easy +-- way to generate a 'MutPart' for every single field, if you have +-- a product type --- see 'hkdMutParts' for more information. +newtype MutPart m s a = MutPart { getMutPart :: Ref m s -> Ref m a } + +-- | Compose two 'MutPart's one after the other. +-- +-- Note this is also available (albeit flipped in arguments) through the +-- 'C.Category' instance. +compMP :: MutPart m a b -> MutPart m b c -> MutPart m a c +compMP (MutPart f) (MutPart g) = MutPart (g . f) +infixr 9 `compMP` + +-- | The identity 'MutPart': simply focus into the same type itself. +-- +-- Note this is also available through the 'C.Category' instance. +idMP :: MutPart m a a +idMP = MutPart id + +instance C.Category (MutPart m) where + id = idMP + (.) = flip compMP + +instance X.IsoHKD (MutPart m s) a + +-- | 'MutPart' into the first field of a tuple reference. +mutFst :: MutPart m (a, b) a +mutFst = MutPart fst + +-- | 'MutPart' into the second field of a tuple reference. +mutSnd :: MutPart m (a, b) b +mutSnd = MutPart snd + +-- | Using a 'MutPart', perform a function on a @'Ref' m s@ as if you had +-- a @'Ref' m a@. +withPart + :: MutPart m s a -- ^ How to zoom into an @a@ from an @s@ + -> Ref m s -- ^ The larger reference of @s@ + -> (Ref m a -> m r) -- ^ What do do with the smaller sub-reference of @a@ + -> m r +withPart mp x f = f (getMutPart mp x) + +-- | With a 'MutPart', read out a specific part of a 'Ref'. +freezePart :: Mutable m a => MutPart m s a -> Ref m s -> m a +freezePart mp = freezeRef . getMutPart mp + +-- | With a 'MutPart', overwrite into a specific part of a 'Ref'. +copyPart :: Mutable m a => MutPart m s a -> Ref m s -> a -> m () +copyPart mp = copyRef . getMutPart mp + +-- | With a 'MutPart', copy a 'Ref' containing a subvalue into a specific +-- part of a larger 'Ref'. +-- +-- @ +-- data MyType = MT { mtInt :: Int, mtDouble :: Double } +-- deriving Generic +-- +-- instance Mutable m MyType where +-- type Ref m MyType = GRef m MyType +-- @ +-- +-- @ +-- ghci> x <- thawRef $ MyType 3 4.5 +-- ghci> y <- thawRef $ 100 +-- ghci> movePartInto (fieldMut #mtInt) x y +-- ghci> freezeRef x +-- MyType 100 4.5 +-- @ +movePartInto + :: Mutable m a + => MutPart m s a + -> Ref m s -- ^ bigger type (destination) + -> Ref m a -- ^ smaller type (source) + -> m () +movePartInto mp = moveRef . getMutPart mp + +-- | With a 'MutPart', copy a specific part of a larger 'Ref' into a 'Ref' +-- of the smaller subvalue value. +-- +-- @ +-- data MyType = MT { mtInt :: Int, mtDouble :: Double } +-- deriving Generic +-- +-- instance Mutable m MyType where +-- type Ref m MyType = GRef m MyType +-- @ +-- +-- @ +-- ghci> x <- thawRef $ MyType 3 4.5 +-- ghci> y <- thawRef $ 100 +-- ghci> movePartOver (fieldMut #mtInt) y x +-- ghci> freezeRef y +-- 3 +-- @ +movePartOver + :: Mutable m a + => MutPart m s a + -> Ref m a -- ^ smaller type (destination) + -> Ref m s -- ^ bigger type (source) + -> m () +movePartOver mp r = moveRef r . getMutPart mp + +-- | With a 'MutPart', copy a specific part of a large 'Ref' into that +-- same part in another large 'Ref'. +-- +-- @ +-- data MyType = MT { mtInt :: Int, mtDouble :: Double } +-- deriving Generic +-- +-- instance Mutable m MyType where +-- type Ref m MyType = GRef m MyType +-- @ +-- +-- @ +-- ghci> x <- thawRef $ MyType 3 4.5 +-- ghci> y <- thawRef $ MyType 100 12.34 +-- ghci> movePartWithin (fieldMut #mtInt) x y +-- ghci> freezeRef x +-- MyType 100 4.5 +-- @ +movePartWithin + :: Mutable m a + => MutPart m s a + -> Ref m s -- ^ destination + -> Ref m s -- ^ source + -> m () +movePartWithin mp r v = moveRef (getMutPart mp r) (getMutPart mp v) + +-- | Clone out a subvalue of a larger 'Ref'. +clonePart + :: Mutable m a + => MutPart m s a + -> Ref m s + -> m (Ref m a) +clonePart mp = cloneRef . getMutPart mp + +-- | A non-copying version of 'unsafeFreezeRef' that can be more efficient for +-- types where the mutable representation is the same as the immutable +-- one (like 'V.Vector'). +-- +-- This is safe as long as you never again modify the mutable +-- reference, since it can potentially directly mutate the frozen value +-- magically. +unsafeFreezePart :: Mutable m a => MutPart m s a -> Ref m s -> m a +unsafeFreezePart mp = unsafeFreezeRef . getMutPart mp + + + +-- | With a 'MutPart', modify a specific part of a 'Ref' with a pure +-- function. +modifyPart :: Mutable m a => MutPart m s a -> Ref m s -> (a -> a) -> m () +modifyPart mp = modifyRef . getMutPart mp + +-- | 'modifyPart', but forces the result before storing it back in the +-- reference. +modifyPart' :: Mutable m a => MutPart m s a -> Ref m s -> (a -> a) -> m () +modifyPart' mp = modifyRef' . getMutPart mp + +-- | 'updateRef', under a 'MutPart' to only modify a specific part of +-- a 'Ref'. +updatePart :: Mutable m a => MutPart m s a -> Ref m s -> (a -> (a, b)) -> m b +updatePart mp = updateRef . getMutPart mp + +-- | 'updatePart', but forces the result before storing it back in the +-- reference. +updatePart' :: Mutable m a => MutPart m s a -> Ref m s -> (a -> (a, b)) -> m b +updatePart' mp = updateRef' . getMutPart mp + +-- | With a 'MutPart', modify a specific part of a 'Ref' with a monadic +-- function. Uses 'copyRef' into the reference after the action is +-- completed. +modifyPartM :: Mutable m a => MutPart m s a -> Ref m s -> (a -> m a) -> m () +modifyPartM mp = modifyRefM . getMutPart mp + +-- | 'modifyPartM', but forces the result before storing it back in the +-- reference. +modifyPartM' :: Mutable m a => MutPart m s a -> Ref m s -> (a -> m a) -> m () +modifyPartM' mp = modifyRefM' . getMutPart mp + +-- | 'updateRefM', under a 'MutPart' to only modify a specific part of +-- a 'Ref'. 'copyRef' into the reference after the action is completed. +updatePartM :: Mutable m a => MutPart m s a -> Ref m s -> (a -> m (a, b)) -> m b +updatePartM mp = updateRefM . getMutPart mp + +-- | 'updatePartM', but forces the result before storing it back in the +-- reference. +updatePartM' :: Mutable m a => MutPart m s a -> Ref m s -> (a -> m (a, b)) -> m b +updatePartM' mp = updateRefM' . getMutPart mp + +-- | A 'MutPart' for a field in a vinyl 'Data.Vinyl.Rec', automatically +-- generated as the first field with a matching type. This is polymorphic +-- to work over both 'Data.Vinyl.Rec' and 'Data.Vinyl.ARec'. +-- +-- @ +-- ghci> r <- 'thawRef' $ [1,2,3] 'V.:&' [True, False] :& 'V.RNil' +-- ghci> modifyPart (mutRec @Bool) r reverse +-- ghci> freezeRef r +-- [1,2,3] :& [False, True] :& RNil +-- @ +mutRec + :: forall a as f rec m. + ( Ref m (rec f as) ~ rec (RecRef m f) as + , RecElem rec a a as as (V.RIndex a as) + , RecElemFCtx rec (RecRef m f) + ) + => MutPart m (rec f as) (f a) +mutRec = MutPart $ getRecRef . rget @a @as @(RecRef m f) @rec + +-- | A 'MutPart' to get into a 'CoerceRef'. +coerceRef :: (Ref m s ~ CoerceRef m s a) => MutPart m s a +coerceRef = MutPart coerce + +-- | Handy wrapper over @'getMutPart' 'coerceRef'@. +withCoerceRef + :: CoerceRef m s a + -> (Ref m a -> m r) + -> m r +withCoerceRef x f = f (coerce x) + +-- | Typeclass used to implement 'hkdMutParts'. See documentation of +-- 'hkdMutParts' for more information. +class (Mutable m (z Identity), Ref m (z Identity) ~ z (RefFor m)) => HKDMutParts m z i o where + hkdMutParts_ :: (z (RefFor m) -> i a) -> o a + +instance (Mutable m (z Identity), Ref m (z Identity) ~ z (RefFor m)) => HKDMutParts m z (K1 i (RefFor m c)) (K1 i (MutPart m (z Identity) c)) where + hkdMutParts_ f = K1 $ MutPart $ getRefFor . unK1 . f + +instance (Mutable m (z Identity), Ref m (z Identity) ~ z (RefFor m)) => HKDMutParts m z U1 U1 where + hkdMutParts_ _ = U1 + +instance (Mutable m (z Identity), Ref m (z Identity) ~ z (RefFor m), TypeError ('Text "Cannot use hkdMutParts for uninhabited types: " ':<>: 'ShowType z)) => HKDMutParts m z V1 V1 where + hkdMutParts_ _ = undefined + +instance HKDMutParts m z i o => HKDMutParts m z (M1 a b i) (M1 a b o) where + hkdMutParts_ f = M1 $ hkdMutParts_ @m (unM1 . f) + +instance (HKDMutParts m z i o, HKDMutParts m z i' o') => HKDMutParts m z (i :*: i') (o :*: o') where + hkdMutParts_ f = hkdMutParts_ @m ((\(x:*:_)->x) . f) :*: hkdMutParts_ @m ((\(_:*:y)->y) . f) + +instance (Mutable m (z Identity), Ref m (z Identity) ~ z (RefFor m), TypeError ('Text "Cannot use hkdMutParts for sum types: " ':<>: 'ShowType z)) => HKDMutParts m z (i :+: i') o where + hkdMutParts_ _ = undefined + +-- | If you are using the "higher-kinded data" pattern, a la +-- , and you +-- have the appropriate instance for 'Ref', then you can use this to +-- generate a 'MutPart' for every field, if you have a type with only one +-- constructor. +-- +-- @ +-- data MyTypeF f = MT +-- { mtInt :: f Int +-- , mtDouble :: f Double +-- } +-- deriving Generic +-- +-- instance Mutable (MyTypeF 'Identity') where +-- type Ref (MyTypeF 'Identity') = MyTypeF ('RefFor' m) +-- +-- mx :: MutPart m (MyTypeF Identity) ('V.Vector' Int) +-- my :: MutPart m (MyTypeF Identity) (Vector Double) +-- MT mx my = hkdMutParts @MyTypeF +-- @ +-- +-- @ +-- ghci> r <- thawRef (MT 3 4.5) +-- ghci> 'freezePart' mx r +-- 3 +-- ghci> 'copyPart' (mtDouble (hkdMutParts @MyTypeF)) r 12.3 +-- ghci> 'freezeRef' r +-- MT 3 12.3 +-- @ +-- +-- Performance-wise, this is about equivalent to 'fieldMut' and 'posMut' +-- for the most part, so the main advantage would be purely syntactical. If +-- performance is an issue, you should benchmark all the different ways +-- just to be sure. As a general rule, it seems like deep nested accesses +-- are faster with composition of 'fieldMut' and 'posMut', but immediate +-- shallow access is often faster with 'hkdMutParts'...but this probably +-- does vary on a case-by-case basis. +hkdMutParts + :: forall z m. + ( Generic (z (RefFor m)) + , Generic (z (MutPart m (z Identity))) + , HKDMutParts m z (Rep (z (RefFor m))) (Rep (z (MutPart m (z Identity)))) + ) + => z (MutPart m (z Identity)) +hkdMutParts = to $ hkdMutParts_ @m @z from + +-- | Create a 'MutPart' for a field name. Should work for any type with +-- one constructor whose mutable reference is 'GRef'. See 'fieldMut' for +-- usage directions. +-- +-- Mostly leverages the power of "Data.Generics.Product.Fields". +class (Mutable m s, Mutable m a) => FieldMut (fld :: Symbol) m s a | fld s -> a where + -- | Create a 'MutPart' for a field name. Should work for any type with + -- one constructor whose mutable reference is 'GRef'. + -- + -- Is meant to be used with OverloadedLabels: + -- + -- @ + -- data MyType = MyType { mtInt :: Int, mtDouble :: Double } + -- deriving (Generic, Show) + -- + -- instance Mutable m MyType where + -- type Ref m MyType = 'GRef' m MyType + -- @ + -- + -- @ + -- ghci> r <- 'thawRef' (MyType 3 4.5) + -- ghci> 'freezePart' ('fieldMut' #mtInt) r + -- 3 + -- ghci> 'copyPart' (fieldMut #mtDouble) 1.23 + -- ghci> 'freezeRef' r + -- MyType 3 1.23 + -- @ + -- + -- However, you can use it without OverloadedLabels by using 'Label' with + -- TypeApplications: + -- + -- @ + -- ghci> 'freezePart' ('fieldMut' ('Label' @"mtInt")) r + -- 3 + -- @ + -- + -- This and 'posMut' are the main ways to generate a 'MutPart' for + -- a type whose mutable reference is 'GRef'. Note that because all of + -- the lookups are done at compile-time, 'fieldMut' and 'posMut' have + -- more or less identical performance characteristics. + fieldMut + :: Label fld -- ^ field label (usually given using OverloadedLabels, @#blah) + -> MutPart m s a + +instance + ( Mutable m s + , Mutable m a + , Ref m s ~ GRef m s + , GL.GLens' (HasTotalFieldPSym fld) (GRef_ m (Rep s)) (Ref m a) + , GL.HasField' fld s a + ) + => FieldMut fld m s a where + fieldMut _ = MutPart $ GLP.view (GL.glens @(HasTotalFieldPSym fld)) . unGRef + +data HasTotalFieldPSym :: Symbol -> GL.TyFun (Type -> Type) (Maybe Type) +type instance GL.Eval (HasTotalFieldPSym sym) tt = GL.HasTotalFieldP sym tt + +-- | A helpful wrapper over @'withPart' ('fieldMut' #blah)@. Create +-- a 'fieldMut' and directly use it. +withField + :: FieldMut fld m s a + => Label fld -- ^ field label (usually given using OverloadedLabels, @#blah) + -> Ref m s -- ^ Larger record reference + -> (Ref m a -> m b) -- ^ What to do with the mutable field + -> m b +withField l = withPart (fieldMut l) + +-- | A helpful wrapper around @'getMutPart' ('fieldMut' #blah)@. Directly +-- use a 'fieldMut' to access a mutable field. +mutField + :: forall fld m s a. FieldMut fld m s a + => Label fld -- ^ field label (usually given using OverloadedLabels, @#blah) + -> Ref m s -- ^ Larger record reference + -> Ref m a -- ^ Internal mutable field +mutField = getMutPart . fieldMut @_ @m + +-- | Create a 'MutPart' for a position in a product type. Should work for any +-- type with one constructor whose mutable reference is 'GRef'. See +-- 'posMut' for usage directions. +-- +-- Mostly leverages the power of "Data.Generics.Product.Positions". +class (Mutable m s, Mutable m a) => PosMut (i :: Nat) m s a | i s -> a where + -- | Create a 'MutPart' for a position in a product type. Should work for any + -- type with one constructor whose mutable reference is 'GRef'. + -- + -- Meant to be used with TypeApplications: + -- + -- @ + -- data MyType = MyType Int Double + -- deriving (Generic, Show) + -- + -- instance Mutable m MyType where + -- type Ref m MyType = 'GRef' m MyType + -- @ + -- + -- @ + -- ghci> r <- 'thawRef' (MyType 3 4.5) + -- ghci> 'freezePart' ('posMut' \@1) r + -- 3 + -- ghci> 'copyPart' (posMut \@2) 1.23 + -- ghci> 'freezeRef' r + -- MyType 3 1.23 + -- @ + -- + -- This and 'fieldMut' are the main ways to generate a 'MutPart' for + -- a type whose mutable reference is 'GRef'. Note that because all of + -- the lookups are done at compile-time, 'posMut' and 'fieldMut' have + -- more or less identical performance characteristics. + posMut :: MutPart m s a + +instance + ( Mutable m s + , Mutable m a + , Ref m s ~ GRef m s + , gref ~ Fst (Traverse (GRef_ m (GL.CRep s)) 1) + , Coercible (GRef_ m (Rep s) ()) (gref ()) + , GL.GLens' (HasTotalPositionPSym i) gref (Ref m a) + , GL.HasPosition' i s a + ) + => PosMut i m s a where + posMut = MutPart $ GLP.view (GL.glens @(HasTotalPositionPSym i) @gref) . coerce @_ @(gref ()) . unGRef + +data HasTotalPositionPSym :: Nat -> GL.TyFun (Type -> Type) (Maybe Type) +type instance GL.Eval (HasTotalPositionPSym t) tt = GL.HasTotalPositionP t tt + +-- | A helpful wrapper over @'withPart' ('posMut' \@n)@. Create +-- a 'posMut' and directly use it. +withPos + :: forall i m s a r. PosMut i m s a + => Ref m s -- ^ Larger record reference + -> (Ref m a -> m r) -- ^ What to do with the mutable field + -> m r +withPos = withPart (posMut @i) + +-- | A helpful wrapper around @'getMutPart' ('posMut' \@n)@. Directly +-- use a 'posMut' to access a mutable field. +mutPos + :: forall i m s a. PosMut i m s a + => Ref m s -- ^ Larger record reference + -> Ref m a -- ^ Internal mutable field +mutPos = getMutPart (posMut @i @m) + +-- | Create a 'MutPart' splitting out a product type into a tuple of refs +-- for every field in that product type. Should work for any type with one +-- constructor whose mutable reference is 'GRef'. See 'tupleMut' for usage +-- directions. +-- +-- Mostly leverages the power of "Data.Generics.Product.HList". +class (Mutable m s, Mutable m a) => TupleMut m s a | s -> a where + -- | Create a 'MutPart' splitting out a product type into a tuple of refs + -- for every field in that product type. Should work for any type with one + -- constructor whose mutable reference is 'GRef'. + -- + -- Probably most easily used using 'withTuple': + -- + -- @ + -- data MyType = MyType Int Double + -- deriving (Generic, Show) + -- + -- instance Mutable m MyType where + -- type Ref m MyType = 'GRef' m MyType + -- @ + -- + -- Now there is an instance of @'TupleMut' m MyType (Int, Double)@. + -- + -- @ + -- ghci> r <- 'thawRef' (MyType 3 4.5) + -- ghci> 'withTuple' r $ \(rI, rD) -> do + -- .. 'modifyRef' rI negate + -- .. modifyRef rD (* 2) + -- ghci> 'freezeRef' r + -- MyType (-3) 9 + -- @ + -- + -- As can be seen, within the lambda, we can get access to every + -- mutable reference inside a @MyType@ reference. + -- + -- Performance-wise, this appears to be faster than 'fieldMut' and + -- 'posMut' when using a single reference, but slower if using all + -- references. + tupleMut :: MutPart m s a + +instance + ( Mutable m s + , Mutable m a + , Ref m s ~ GRef m s + , GL.GIsList (GRef_ m (Rep s)) (GRef_ m (Rep s)) (MapRef m as) (MapRef m as) + , GL.GIsList (Rep s) (Rep s) as as + , GL.ListTuple a as + , GL.ListTuple b (MapRef m as) + , Ref m a ~ b + ) + => TupleMut m s a where + tupleMut = MutPart $ GL.listToTuple + . GLP.view GL.glist + . unGRef + +-- | A helpful wrapper over @'withPart' 'tupleMut'@. Directly operate on +-- the items in the data type, getting the references as a tuple. See +-- 'tupleMut' for more details on when this should work. +-- +-- @ +-- data MyType = MyType Int Double +-- deriving (Generic, Show) +-- +-- instance Mutable m MyType where +-- type Ref m MyType = 'GRef' m MyType +-- @ +-- +-- @ +-- ghci> r <- 'thawRef' (MyType 3 4.5) +-- ghci> 'withTuple' r $ \(rI, rD) -> do +-- .. 'modifyRef' rI negate +-- .. modifyRef rD (* 2) +-- ghci> 'freezeRef' r +-- MyType (-3) 9 +-- @ +withTuple + :: TupleMut m s a + => Ref m s -- ^ Larger record reference + -> (Ref m a -> m r) -- ^ What to do with each mutable field. The + -- @'Ref' m a@ will be a tuple of every field's ref. + -> m r +withTuple = withPart tupleMut + + +-- stuff from generic-lens that wasn't exported + +type G = Type -> Type + +type family Traverse (a :: G) (n :: Nat) :: (G, Nat) where + Traverse (M1 mt m s) n + = Traverse1 (M1 mt m) (Traverse s n) + Traverse (l :+: r) n + = '(Fst (Traverse l n) :+: Fst (Traverse r n), n) + Traverse (l :*: r) n + = TraverseProd (:*:) (Traverse l n) r + Traverse (K1 _ p) n + = '(K1 (GL.Pos n) p, n + 1) + Traverse U1 n + = '(U1, n) + +type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, Nat) where + Traverse1 w '(i, n) = '(w i, n) + +-- | For products, we first traverse the left-hand side, followed by the second +-- using the counter returned by the left traversal. +type family TraverseProd (c :: G -> G -> G) (a :: (G, Nat)) (r :: G) :: (G, Nat) where + TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n) + +type family Fst (p :: (a, b)) :: a where + Fst '(a, b) = a