hkd-records (empty) → 0.0.1
raw patch · 5 files changed
+355/−0 lines, 5 filesdep +basedep +hkddep +textsetup-changed
Dependencies added: base, hkd, text
Files
- CHANGELOG.md +5/−0
- LICENSE +27/−0
- Setup.hs +2/−0
- hkd-records.cabal +29/−0
- src/Data/HKD/Records.hs +292/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hkd-records++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2021, Kristof Bastiaensen+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 the {organization} nor the names of its+ 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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hkd-records.cabal view
@@ -0,0 +1,29 @@+name: hkd-records+version: 0.0.1+cabal-version: >=1.10+synopsis: higher kinded record operations+description: make higher kinded records great again+-- bug-reports:+license: BSD3+license-file: LICENSE+author: Kristof Bastiaensen+maintainer: kristof@resonata.be+copyright: Kristof Bastiaensen (2022)+category: Records+build-type: Simple+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/kuribas/hkd-records++Library+ Ghc-options: -Wall+ default-language: Haskell2010+ Build-depends: base >= 3 && < 5,+ hkd >= 0.1 && < 0.2,+ text >= 1.2 && < 1.3+ hs-source-dirs:+ src + Exposed-Modules:+ Data.HKD.Records
+ src/Data/HKD/Records.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE DeriveGeneric #-}+module Data.HKD.Records (+ FLabels(..), gflabels,+ Dict(..), FDicts(..), gfdicts,+ HkdProd(..), LkdProd(..), End,+ fzipManyWith, ftoList, Lens', FLens(..),+ FLenses(..), gflenses) where+import Data.HKD+import Data.Text (Text)+import Data.Functor.Const+import GHC.Generics+import GHC.TypeLits+import Data.Coerce+import qualified Data.Text as Text+import Data.Proxy+import Data.Monoid+import Data.Functor.Identity+import Data.List++class FLabels t where+ -- | get the labels from each field as a (Const Text).+ flabels :: t (Const Text)++class GLabels t where+ genFlabels :: t+ +instance (GLabels (f ()), GLabels (g ())) => GLabels ((f :*: g) ()) where+ genFlabels = genFlabels :*: genFlabels+ {-# INLINE genFlabels #-}++instance KnownSymbol label =>+ (GLabels (S1 ('MetaSel ('Just label) _x _x2 _x3)+ (Rec0 (Const Text b))+ ())) where+ genFlabels = M1 $ K1 $ Const (Text.pack $ symbolVal (Proxy @label))+ {-# INLINE genFlabels #-}+ +instance GLabels (b ()) => (GLabels ((D1 meta (C1 meta2 b)) ())) where+ genFlabels = M1 $ M1 $ genFlabels+ {-# INLINE genFlabels #-}++-- | Automatically derive flabels using generics. This only requires+-- a Generic instance for your datatype.+gflabels :: forall t . (Generic (t (Const Text)),+ GLabels (Rep (t (Const Text)) ()))+ => t (Const Text)+gflabels = to (genFlabels :: Rep (t (Const Text)) ())+ +data Dict c (t :: k) where+ -- | reified type class dictionary. You need to put the constructor+ -- in scope in order to use the contained typeclass dictionaries.+ Dict :: c t => Dict c t++class FDicts c t where+ -- | hkd record containing the reified type class dictionaries for+ -- each field.+ fdicts :: t (Dict c)++class GFDicts t where+ genFdict :: t++instance (GFDicts (f ()), GFDicts (g ())) => GFDicts ((f :*: g) ()) where+ genFdict = genFdict :*: genFdict+ {-# INLINE genFdict #-}++instance c b =>+ GFDicts (S1 ('MetaSel _x1 _x2 _x3 _x4)+ (Rec0 (Dict c b))+ ()) where+ genFdict = M1 $ K1 $ Dict+ {-# INLINE genFdict #-}++instance GFDicts (b ()) => (GFDicts ((D1 meta (C1 meta2 b)) ())) where+ genFdict = M1 $ M1 $ genFdict+ {-# INLINE genFdict #-}++-- | Automatically derive fdict using generics. This only requires a+-- Generic instance for your datatype.+gfdicts :: forall t c . (Generic (t (Dict c)),+ GFDicts (Rep (t (Dict c)) ()))+ => t (Dict c)+gfdicts = to (genFdict :: Rep (t (Dict c)) ())++infixr 5 :>+infixr 5 :~>++-- | A heterogenous list of higher kinded records. Use `:~>` to+-- separate the items, and `End` to terminate them.+data HkdProd (f :: a -> *) g t = t f :~> g t+-- | A heterogenous list of fields. Use `:>` to separate the items,+-- and `End` to terminate them.+data LkdProd f g (x :: a) = f x :> g x+-- | The terminator.+data End (t :: k) = End++class GFTranspose x t (f :: a -> *) | x -> f where+ gftranspose :: x t -> t f++instance FRepeat t => GFTranspose End t End where+ gftranspose End = frepeat End++instance (FZip t, GFTranspose g t g') => + GFTranspose (HkdProd f g) t (LkdProd f g') where+ gftranspose (tf :~> tg) = fzipWith (:>) tf $ gftranspose tg++-- | zip over many arguments. The function must take a heterogenous+-- list of fields, separated using `:>` and terminated by `End`,+-- while the argument must be a heterogenous list of records,+-- separated by `:~>`, end terminated by `End`.+--+-- For example:+--+-- @+-- zipShow :: (FFoldable t, FRepeat t, FLabels t, FDicts Show t, FZip t) =>+-- t Identity -> Text+-- zipShow t =+-- Text.concat $+-- intersperse "&" $+-- ftoList $ +-- fzipManyWith+-- (\(Identity y :> Const lbl :> Dict :> End) ->+-- Const $ lbl <> "=" <> Text.pack (show y))+-- (t :~> flabels :~> fdicts @Show :~> End)+-- @++fzipManyWith :: ( FFunctor t, GFTranspose x t f) =>+ (forall a. f a -> i a) ->+ (x t -> t i)+fzipManyWith f tuple = ffmap f $ gftranspose tuple++type Lens' a s = forall f . Functor f => (a -> f a) -> s -> f s++-- | A lens for targetting a field of a higher kinded structure. This+-- must be a newtype in order to be partially applied.+newtype FLens g s a = FLens (Lens' (g a) (s g))++iso :: (a -> s) -> (s -> a) -> Lens' a s+iso wrap unwrap f g = wrap <$> f (unwrap g)+{-# INLINE iso #-}++compFLens :: Lens' (s g) (t g) -> FLens g s a -> FLens g t a+compFLens l (FLens m) = FLens (l . m)+{-# INLINE compFLens #-}++compIsoFLens :: (s g -> t g) -> (t g -> s g) -> FLens g s a -> FLens g t a+compIsoFLens wrap unwrap = compFLens (iso wrap unwrap)+{-# INLINE compIsoFLens #-}++class FLenses t where+ -- A record of lenses into the record.+ flenses :: t (FLens g t)++-- newtype to get rid of the extra type variable+newtype Tupled f (a :: k) = Tupled {unTupled :: f a ()}++-- these newtypes just rearrange the type variables so they +newtype FunctorS1 label _x _x2 _x3 a g k =+ FunctorS1 { getFunctorS1 :: (S1 ('MetaSel label _x _x2 _x3)+ (Rec0 (g a))+ k)}++newtype FunctorD1 meta meta2 f l k =+ FunctorD1 { getFunctorD1 ::D1 meta (C1 meta2 (f l)) k }++newtype FunctorProd f g a k = FunctorProd ((f a :*: g a) k)++instance FFunctor (Tupled (FunctorS1 label _x _x2 _x3 a)) where+ ffmap f (Tupled (FunctorS1 (M1 (K1 x))))+ = Tupled $ FunctorS1 $ M1 $ K1 $ f x+ {-# INLINE ffmap #-}++instance FFunctor (Tupled f)+ => FFunctor (Tupled (FunctorD1 meta meta2 f)) where+ ffmap f (Tupled (FunctorD1 (M1 (M1 x)))) =+ Tupled $ FunctorD1 $ M1 $ M1 $ unTupled $ ffmap f $ Tupled x+ {-# INLINE ffmap #-}++instance ( FFunctor (Tupled f)+ , FFunctor (Tupled g)+ ) =>+ FFunctor (Tupled (FunctorProd f g)) where+ ffmap f (Tupled (FunctorProd (x :*: y))) =+ Tupled $ FunctorProd $+ unTupled (ffmap f (Tupled x)) :*:+ unTupled (ffmap f (Tupled y))+ {-# INLINE ffmap #-}++class Coercible (x ()) (Tupled r g) =>+ GFLenses (x :: * -> *) k (r :: (k -> *) -> * -> *) g | x -> k, x -> r where+ genflenses :: Tupled r (FLens g (Tupled r))+ +instance GFLenses ((S1 ('MetaSel label _x _x2 _x3)+ (Rec0 (g (a :: k))) :: * -> *))+ k+ (FunctorS1 label _x _x2 _x3 a)+ g where+ genflenses = Tupled $ FunctorS1 $ M1 $ K1 $ FLens $ \f g ->+ ( Tupled . FunctorS1 . M1 . K1 ) <$>+ f (unK1 . unM1 . getFunctorS1 . unTupled $ g)+ {-# INLINE genflenses #-}++instance+ ( FFunctor (Tupled r)+ , GFLenses x k r g+ ) =>+ GFLenses (D1 meta (C1 meta2 x)) k (FunctorD1 meta meta2 r) g where+ genflenses = Tupled $ FunctorD1 $ M1 $ M1 $+ unTupled $+ ffmap (compIsoFLens+ (Tupled . FunctorD1 . M1 . M1 . unTupled)+ (Tupled . unM1 . unM1 . getFunctorD1 . unTupled)) $+ (genflenses @x)+ {-# INLINE genflenses #-}++instance ( FFunctor (Tupled r1)+ , FFunctor (Tupled r2)+ , Coercible ((x :*: y) ()) (Tupled (FunctorProd r1 r2) g)+ , GFLenses x k r1 g+ , GFLenses y k r2 g+ ) =>+ GFLenses (x :*: y) k (FunctorProd r1 r2) g+ where+ genflenses = Tupled $ FunctorProd $+ unTupled (ffmap (compFLens $+ \f (Tupled (FunctorProd (a :*: b))) ->+ (Tupled . FunctorProd . (:*: b) . unTupled)+ <$> f (Tupled a))+ (genflenses @x)) :*:+ unTupled (ffmap (compFLens $+ \f (Tupled (FunctorProd (a :*: b))) ->+ (Tupled . FunctorProd . (a :*:) . unTupled)+ <$> f (Tupled b))+ (genflenses @y))+ + {-# INLINE genflenses #-}++type GFlensesMachinery k t r g =+ ( Generic (t g)+ , Generic (t (FLens g (Tupled r)))+ , Coercible (r (FLens g (Tupled r)) ())+ (Rep (t (FLens g (Tupled r))) ())+ , FFunctor (t :: (k -> *) -> *)+ , FFunctor (Tupled r)+ , GFLenses (Rep (t g)) k (r :: (k -> *) -> * -> *) g+ )++-- | Autogenerate lenses using generics. You only need to derive+-- Generic for the datatype.+gflenses :: forall k t r g . GFlensesMachinery k t r g+ => t (FLens g t)+gflenses = ffmap (compIsoFLens toHkd fromHkd) $+ toHkd (genflenses @(Rep (t g)) @k @r)+{-# INLINE gflenses #-}++toHkd :: forall t g r.+ ( Generic (t g)+ , Coercible (r g ()) (Rep (t g) ())+ ) =>+ Tupled r g -> t g+toHkd t = to (coerce t :: Rep (t g) ())+{-# INLINE toHkd #-} ++fromHkd :: forall t g r.+ ( Generic (t g)+ , Coercible (r g ()) (Rep (t g) ())+ ) =>+ t g -> Tupled r g+fromHkd r = coerce (from r :: Rep (t g) ())+{-# INLINE fromHkd #-}++-- | collect (Const) elements into a list efficiently.+ftoList :: FFoldable t => t (Const a) -> [a]+ftoList = flip appEndo [] . ffoldMap (Endo . (:) . getConst)+