mutable 0.2.0.0 → 0.2.1.0
raw patch · 6 files changed
+304/−85 lines, 6 filesdep +template-haskell
Dependencies added: template-haskell
Files
- CHANGELOG.md +12/−0
- mutable.cabal +4/−2
- src/Data/Mutable/Branches.hs +1/−23
- src/Data/Mutable/Instances.hs +38/−59
- src/Data/Mutable/Internal.hs +24/−1
- src/Data/Mutable/Internal/TH.hs +225/−0
CHANGELOG.md view
@@ -1,6 +1,18 @@ Changelog ========= +Version 0.2.1.0+---------------++*July 6, 2020*++<https://github.com/mstksg/mutable/releases/tag/v0.2.1.0>++* Use TH to generate tuple instances for `Mutable` up to 12.+* Use TH to generate `ListRefTuple` instances for lists up to length 12.+ Previously the instances up to the maximum length of `Mutable` tuple+ instances were missing.+ Version 0.2.0.0 ---------------
mutable.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: b7384039190c92bb1ccdc49dabc8288ac734520f4aa13ad47f6893e933a83ebb+-- hash: ffd197df55f7f93dd8ec419431fdd2c85526097855d397d55d17828e1eebbe95 name: mutable-version: 0.2.0.0+version: 0.2.1.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".@@ -44,6 +44,7 @@ Data.Mutable.Branches Data.Mutable.Class Data.Mutable.Instances+ Data.Mutable.Internal.TH Data.Mutable.Parts other-modules: Data.Mutable.Internal@@ -58,6 +59,7 @@ , microlens , primitive >=0.6.4 , reflection+ , template-haskell , transformers , vector , vinyl
src/Data/Mutable/Branches.hs view
@@ -60,10 +60,10 @@ import Control.Monad import Control.Monad.Primitive import Data.Generics.Product.Internal.HList-import Data.Kind import Data.Maybe import Data.Mutable.Class import Data.Mutable.Instances+import Data.Mutable.Internal import Data.Primitive.MutVar import GHC.Generics import GHC.OverloadedLabels@@ -697,25 +697,3 @@ -- | 'MutBranch' focusing on the 'Right' case of an 'Either' rightMB :: (Mutable s a, Mutable s b) => MutBranch s (Either a b) b rightMB = constrMB #_Right--class ListRefTuple (s :: Type) (b :: Type) (as :: [Type]) | as s -> b where- tupledRef :: GL.Iso' (HList (MapRef s as)) b- tupledRef = GL.iso (listRefToTuple @s @b @as) (tupleToListRef @s @b @as)- {-# INLINE tupledRef #-}- tupleToListRef :: b -> HList (MapRef s as)- listRefToTuple :: HList (MapRef s as) -> b--instance ListRefTuple s (UnitRef s) '[] where- tupleToListRef _ = Nil- listRefToTuple _ = UnitRef-instance (Ref s a ~ ra) => ListRefTuple s ra '[a] where- tupleToListRef x = x :> Nil- listRefToTuple (x :> _) = x-instance (Ref s a ~ ra, Ref s b ~ rb) => ListRefTuple s (ra, rb) '[a, b] where- tupleToListRef (x, y) = x :> y :> Nil- listRefToTuple (x :> y :> _) = (x, y)-----
src/Data/Mutable/Instances.hs view
@@ -1,19 +1,20 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE EmptyDataDeriving #-}-{-# 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 #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Mutable.Instances@@ -70,6 +71,7 @@ import Data.Generics.Product.Internal.HList (HList(..)) import Data.Kind import Data.Mutable.Internal+import Data.Mutable.Internal.TH import Data.Ord import Data.Primitive.Array import Data.Primitive.ByteArray@@ -361,42 +363,11 @@ 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+ cloneRef (u , v ) = (,) <$> cloneRef u <*> cloneRef v 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 (Mutable s a, Mutable s b, Mutable s c) => Mutable s (a, b, c) where- type Ref s (a, b, c) = (Ref s a, Ref s b, Ref s 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 (Mutable s a, Mutable s b, Mutable s c, Mutable s d) => Mutable s (a, b, c, d) where- type Ref s (a, b, c, d) = (Ref s a, Ref s b, Ref s c, Ref s 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 (Mutable s a, Mutable s b, Mutable s c, Mutable s d, Mutable s e) => Mutable s (a, b, c, d, e) where- type Ref s (a, b, c, d, e) = (Ref s a, Ref s b, Ref s c, Ref s d, Ref s 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+mutableTuples [3..12] -- | 'Ref' for components in a vinyl 'Rec'. newtype RecRef s f a = RecRef { getRecRef :: Ref s (f a) }@@ -454,16 +425,6 @@ 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 s as where- MapRef s '[] = '[]- MapRef s (a ': as) = Ref s a ': MapRef s as- -- | The mutable reference of the 'HList' type from generic-lens. data HListRef :: Type -> [Type] -> Type where NilRef :: HListRef s '[]@@ -499,3 +460,21 @@ x :> xs -> (:!>) <$> unsafeThawRef x <*> unsafeThawRef xs unsafeFreezeRef = \case v :!> vs -> (:>) <$> unsafeFreezeRef v <*> unsafeFreezeRef vs++-- ListRefTuple instances++-- this one instance is the reason why we have to define a new typeclass+-- instead of using 'ListRef' -- because of @'ListRef' s () '[]@.+instance ListRefTuple s (UnitRef s) '[] where+ tupleToListRef _ = Nil+ listRefToTuple _ = UnitRef++instance (Ref s a ~ ra) => ListRefTuple s ra '[a] where+ tupleToListRef x = x :> Nil+ listRefToTuple (x :> _) = x++instance (Ref s a ~ ra, Ref s b ~ rb) => ListRefTuple s (ra, rb) '[a, b] where+ tupleToListRef (x, y) = x :> y :> Nil+ listRefToTuple (x :> y :> _) = (x, y)++listRefTuples [3..12]
src/Data/Mutable/Internal.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-}@@ -45,6 +46,9 @@ -- ** Instances for Generics combinators themselves , GMutableRef(..) , MutSumF(..)+ -- ** Needed for MutBranch+ , ListRefTuple(..)+ , MapRef ) where import Control.Monad.Primitive@@ -53,12 +57,14 @@ import Data.Bifunctor import Data.Coerce import Data.Foldable+import Data.Generics.Product.Internal.HList import Data.Kind import Data.List import Data.Primitive.MutVar import Data.Vinyl.Functor import GHC.Generics-import qualified Data.Vinyl.XRec as X+import qualified Data.GenericLens.Internal as GL+import qualified Data.Vinyl.XRec as X -- | An instance of @'Mutable' s a@ means that @a@ can be stored -- a mutable reference in a 'PrimMonad' @m@ (where @s@ is the mutable state@@ -1265,3 +1271,20 @@ => z (RefFor s) -> m (z Identity) unsafeFreezeHKD = fmap to . gUnsafeFreezeRef_ . from++-- | 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 s as where+ MapRef s '[] = '[]+ MapRef s (a ': as) = Ref s a ': MapRef s as++class ListRefTuple (s :: Type) (b :: Type) (as :: [Type]) | as s -> b where+ tupledRef :: GL.Iso' (HList (MapRef s as)) b+ tupledRef = GL.iso (listRefToTuple @s @b @as) (tupleToListRef @s @b @as)+ {-# INLINE tupledRef #-}+ tupleToListRef :: b -> HList (MapRef s as)+ listRefToTuple :: HList (MapRef s as) -> b
+ src/Data/Mutable/Internal/TH.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Mutable.Internal.TH (+ mutableTuples+ , listRefTuples+ ) where++import Control.Monad+import Data.Generics.Product.Internal.HList+import Data.List+import Data.Mutable.Internal+import Language.Haskell.TH++tyVarNames :: [String]+tyVarNames = (:[]) <$> filter (/= 's') ['a' .. 'z']++mutableTuples :: [Int] -> Q [Dec]+mutableTuples = traverse mutableTuple++listRefTuples :: [Int] -> Q [Dec]+listRefTuples = traverse listRefTuple+++mutableTuple+ :: Int+ -> Q Dec+mutableTuple n = do+ valVars <- replicateM n (newName "x")+ refVars <- replicateM n (newName "r")+ -- instance (Mutable s a, Mutable s b, Mutable s c) => Mutable s (a, b, c) where+ pure $ InstanceD+ Nothing+ (mutableS . VarT <$> tyVars)+ (mutableS instHead)+ [ refImpl+ , thawImpl valVars+ , freezeImpl refVars+ , copyImpl refVars valVars+ , moveImpl refVars valVars+ , cloneImpl refVars+ , unsafeThawImpl valVars+ , unsafeFreezeImpl refVars+ ]+ where+ tuplerT :: [Type] -> Type+ tuplerT = applyAllT (TupleT n)+ tupConE :: Exp+ tupConE = ConE (tupleDataName n)++ mutableS :: Type -> Type+ mutableS = ((ConT ''Mutable `AppT` VarT (mkName "s")) `AppT`)+ refS :: Type -> Type+ refS = ((ConT ''Ref `AppT` VarT (mkName "s")) `AppT`)+ tyVars :: [Name]+ tyVars = mkName <$> take n tyVarNames+ instHead :: Type+ instHead = tuplerT $ VarT <$> tyVars+ -- type Ref s (a, b, c) = (Ref s a, Ref s b, Ref s c)+ refImpl :: Dec+#if MIN_VERSION_template_haskell(2,15,0)+ refImpl = TySynInstD+ . TySynEqn Nothing (refS instHead)+#else+ refImpl = TySynInstD ''Ref+ . TySynEqn [VarT (mkName "s"), instHead]+#endif+ $ tuplerT (refS . VarT <$> tyVars)+ thawImpl :: [Name] -> Dec+ thawImpl valVars = FunD 'thawRef [+ Clause [TupP (BangP . VarP <$> valVars)]+ (NormalB . liftApplyAllE tupConE $+ (VarE 'thawRef `AppE`) . VarE <$> valVars+ )+ []+ ]+ -- freezeRef (u , v , w ) = (,,) <$> freezeRef u <*> freezeRef v <*> freezeRef w+ freezeImpl :: [Name] -> Dec+ freezeImpl refVars = FunD 'freezeRef [+ Clause [TupP (VarP <$> refVars)]+ (NormalB . liftApplyAllE tupConE $+ (VarE 'freezeRef `AppE`) . VarE <$> refVars+ )+ []+ ]+ -- copyRef (u , v , w ) (!x, !y, !z) = copyRef u x *> copyRef v y *> copyRef w z+ copyImpl :: [Name] -> [Name] -> Dec+ copyImpl refVars valVars = FunD 'copyRef [+ Clause [ TupP (BangP . VarP <$> refVars)+ , TupP (BangP . VarP <$> valVars)+ ]+ (NormalB . sequenceAllE $+ zipWith (\r v -> (VarE 'copyRef `AppE` VarE r) `AppE` VarE v) refVars valVars+ )+ []+ ]+ -- moveRef (u , v , w ) ( x, y, z) = moveRef u x *> moveRef v y *> moveRef w z+ moveImpl :: [Name] -> [Name] -> Dec+ moveImpl refVars valVars = FunD 'moveRef [+ Clause [ TupP (BangP . VarP <$> refVars)+ , TupP (BangP . VarP <$> valVars)+ ]+ (NormalB . sequenceAllE $+ zipWith (\r v -> (VarE 'moveRef `AppE` VarE r) `AppE` VarE v) refVars valVars+ )+ []+ ]+ -- cloneRef (u , v , w ) = (,,) <$> cloneRef u <*> cloneRef v <*> cloneRef w+ cloneImpl :: [Name] -> Dec+ cloneImpl refVars = FunD 'cloneRef [+ Clause [TupP (VarP <$> refVars)]+ (NormalB . liftApplyAllE tupConE $+ (VarE 'cloneRef `AppE`) . VarE <$> refVars+ )+ []+ ]+ -- unsafeThawRef (!x, !y, !z) = (,,) <$> unsafeThawRef x <*> unsafeThawRef y <*> unsafeThawRef z+ unsafeThawImpl :: [Name] -> Dec+ unsafeThawImpl valVars = FunD 'unsafeThawRef [+ Clause [TupP (BangP . VarP <$> valVars)]+ (NormalB . liftApplyAllE tupConE $+ (VarE 'unsafeThawRef `AppE`) . VarE <$> valVars+ )+ []+ ]+ -- unsafeFreezeRef (u , v , w ) = (,,) <$> unsafeFreezeRef u <*> unsafeFreezeRef v <*> unsafeFreezeRef w+ unsafeFreezeImpl :: [Name] -> Dec+ unsafeFreezeImpl refVars = FunD 'unsafeFreezeRef [+ Clause [TupP (VarP <$> refVars)]+ (NormalB . liftApplyAllE tupConE $+ (VarE 'unsafeFreezeRef `AppE`) . VarE <$> refVars+ )+ []+ ]++listRefTuple+ :: Int+ -> Q Dec+listRefTuple n = do+ valVars <- replicateM n (newName "x")+ -- instance (Ref s a ~ ra, Ref s b ~ rb) => ListRefTuple s (ra, rb) '[a, b] where+ pure $ InstanceD+ Nothing+ (zipWith refConstr refVars tyVars)+ (listRefTupleS (tuplerT (VarT <$> refVars)) `AppT`+ (liftedList (VarT <$> tyVars))+ )+ [ tupToListImpl valVars+ , listToTupImpl valVars+ ]+ where+ tuplerT :: [Type] -> Type+ tuplerT = applyAllT (TupleT n)+ tupConE :: Exp+ tupConE = ConE (tupleDataName n)++ listRefTupleS :: Type -> Type+ listRefTupleS = ((ConT ''ListRefTuple `AppT` VarT (mkName "s")) `AppT`)+ refS :: Type -> Type+ refS = ((ConT ''Ref `AppT` VarT (mkName "s")) `AppT`)+ tyVarsStr :: [String]+ tyVarsStr = take n tyVarNames+ tyVars :: [Name]+ tyVars = mkName <$> tyVarsStr+ refVars :: [Name]+ refVars = mkName . ("r" ++) <$> tyVarsStr++ refConstr :: Name -> Name -> Pred+ refConstr r v = (EqualityT `AppT` refS (VarT v))+ `AppT` VarT r++ -- tupleToListRef (x, y) = x :> y :> Nil+ tupToListImpl :: [Name] -> Dec+ tupToListImpl valVars = FunD 'tupleToListRef [+ Clause [TupP (VarP <$> valVars)]+ ( NormalB+ . foldr (\x y -> (ConE '(:>) `AppE` VarE x) `AppE` y) (ConE 'Nil)+ $ valVars+ )+ []+ ]+ -- listRefToTuple (x :> y :> _) = (x, y)+ listToTupImpl :: [Name] -> Dec+ listToTupImpl valVars = FunD 'listRefToTuple [+ Clause [ foldr (\x y -> ConP '(:>) [VarP x, y]) (ConP 'Nil []) valVars+ ]+ ( NormalB . applyAllE tupConE $+ VarE <$> valVars+ )+ []+ ]+++applyAllT+ :: Type+ -> [Type]+ -> Type+applyAllT = foldl' (\t m -> t `AppT` m)++-- | liftApplyAllE f [x,y,z] = f <$> x <*> y <*> z+liftApplyAllE+ :: Exp+ -> [Exp]+ -> Exp+liftApplyAllE = foldl' (\t m -> (VarE '(<*>) `AppE` t) `AppE` m)+ . (VarE 'pure `AppE`)++-- | applyAllE f [x,y,z] = f x y z+applyAllE+ :: Exp+ -> [Exp]+ -> Exp+applyAllE = foldl' (\t m -> t `AppE` m)++-- | sequenceAllE [x,y,z] = x *> y *> z+sequenceAllE+ :: [Exp]+ -> Exp+sequenceAllE = foldr1 (\x y -> (VarE '(*>) `AppE` x) `AppE` y)++liftedList+ :: [Type]+ -> Type+liftedList = foldr (\x y -> (PromotedConsT `AppT` x) `AppT` y) PromotedNilT+