{-# 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.Generics.Product.Internal.HList 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 <- projectBranch (constrMB #_Left) r -- ghci> case s of Just s' -> freezeRef s' -- 10 -- @ -- -- @ -- ghci> r <- thawRef (Right True) -- ghci> s <- projectBranch (constrMB #_Left) r -- 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 , GIsList (GRef_ m f) (GRef_ m f) (MapRef m as) (MapRef m as) , GIsList f f as as , ListTuple a a as as , ListTuple b b (MapRef m as) (MapRef m as) , Ref m a ~ b ) => GMutBranchConstructor ctor m (M1 C ('MetaCons ctor fixity fields) f) a where gmbcProj _ = pure . Just . listToTuple @b @b @(MapRef m as) @(MapRef m as) . GLP.view glist . unM1 gmbcEmbed _ = pure . M1 . GLP.view (GL.fromIso glist) . tupleToList @b @_ @(MapRef m as) 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 , GIsList (GRef_ m l) (GRef_ m l) (MapRef m as) (MapRef m as) , GIsList l l as as , ListTuple a a as as , ListTuple b b (MapRef m as) (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.fromIso glist) . tupleToList @b @_ @(MapRef m as) instance ( PrimMonad m , GMutable m l , GMutBranchConstructor ctor m r a , GIsList (GRef_ m r) (GRef_ m r) (MapRef m as) (MapRef m as) , GIsList r r as as , ListTuple a a as as , ListTuple b b (MapRef m as) (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.fromIso glist) . tupleToList @b @_ @(MapRef m as) -- | 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