module Composite.Record
( Rec((:&), RNil), Record
, pattern (:*:), pattern (:^:)
, (:->)(Val, getVal), valName, valWithName
, RElem, rlens, rlens'
) where
import Control.Lens.TH (makeWrapped)
import Data.Functor.Identity (Identity(Identity))
import Data.Proxy (Proxy(Proxy))
import Data.Semigroup (Semigroup)
import Data.String (IsString)
import Data.Text (Text, pack)
import Data.Vinyl (Rec((:&), RNil))
import qualified Data.Vinyl as Vinyl
import qualified Data.Vinyl.TypeLevel as Vinyl
import Foreign.Storable (Storable)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
type Record = Rec Identity
type RElem r rs = Vinyl.RElem r rs (Vinyl.RIndex r rs)
newtype (:->) (s :: Symbol) a = Val { getVal :: a }
makeWrapped ''(:->)
deriving instance Bounded a => Bounded (s :-> a)
deriving instance Enum a => Enum (s :-> a)
deriving instance Eq a => Eq (s :-> a)
deriving instance Floating a => Floating (s :-> a)
deriving instance Fractional a => Fractional (s :-> a)
deriving instance Integral a => Integral (s :-> a)
deriving instance IsString a => IsString (s :-> a)
deriving instance Monoid a => Monoid (s :-> a)
deriving instance Num a => Num (s :-> a)
deriving instance Ord a => Ord (s :-> a)
deriving instance Real a => Real (s :-> a)
deriving instance RealFloat a => RealFloat (s :-> a)
deriving instance RealFrac a => RealFrac (s :-> a)
deriving instance Semigroup a => Semigroup (s :-> a)
deriving instance Storable a => Storable (s :-> a)
instance Functor ((:->) s) where
fmap f = Val . f . getVal
instance Applicative ((:->) s) where
pure = Val
Val f <*> Val a = Val (f a)
instance Foldable ((:->) s) where
foldr f z (Val a) = f a z
instance Traversable ((:->) s) where
traverse k (Val a) = Val <$> k a
instance Monad ((:->) s) where
return = Val
Val a >>= k = k a
instance forall (s :: Symbol) a. (KnownSymbol s, Show a) => Show (s :-> a) where
showsPrec p (Val a) = ((symbolVal (Proxy :: Proxy s) ++ " :-> ") ++) . showsPrec p a
valName :: forall s a. KnownSymbol s => s :-> a -> Text
valName _ = pack (symbolVal (Proxy :: Proxy s))
valWithName :: forall s a. KnownSymbol s => s :-> a -> (Text, a)
valWithName v = (valName v, getVal v)
pattern (:*:) :: () => () => a -> Rec Identity rs -> Rec Identity (s :-> a ': rs)
pattern (:*:) a rs = Identity (Val a) :& rs
infixr 5 :*:
pattern (:^:) :: Functor f => () => f a -> Rec f rs -> Rec f (s :-> a ': rs)
pattern (:^:) fa rs <- (fmap getVal -> fa) :& rs where
(:^:) fa rs = fmap Val fa :& rs
infixr 5 :^:
rlens :: (Functor g, RElem (s :-> a) rs, Functor g) => proxy (s :-> a) -> (a -> g a) -> Rec Identity rs -> g (Rec Identity rs)
rlens proxy f =
Vinyl.rlens proxy $ \ (Identity (Val a)) ->
Identity . Val <$> f a
rlens' :: (Functor f, Functor g, RElem (s :-> a) rs, Functor g) => proxy (s :-> a) -> (f a -> g (f a)) -> Rec f rs -> g (Rec f rs)
rlens' proxy f =
Vinyl.rlens proxy $ \ (fmap getVal -> fa) ->
fmap Val <$> f fa