barbies-th 0.1.2 → 0.1.3

raw patch · 3 files changed

+49/−5 lines, 3 filesdep +splitPVP ok

version bump matches the API change (PVP)

Dependencies added: split

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• barbies-th.cabal +2/−1
• src/Data/Barbie/TH.hs +42/−4

@@ -1,5 +1,10 @@ # Revision history for barbies-th +## 0.1.3++* Added `LensB` and `getLensB`+* Now derives `AccessorsB`+ ## 0.1.2  * `declareBareB` now derives `DistributiveD`

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                barbies-th-version:             0.1.2+version:             0.1.3 synopsis:            Create strippable HKD via TH description:         Please see Data.Barbie.TH bug-reports:         https://github.com/fumieval/barbies-th@@ -18,6 +18,7 @@   build-depends:       base >= 4.12     , template-haskell >= 2.14 && <2.17     , barbies ^>= 2.0.1+    , split ^>= 0.2   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options: -Wall

@@ -12,11 +12,14 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.Barbie.TH (FieldNamesB(..)+  , LensB(..)+  , getLensB+  , AccessorsB(..)   , declareBareB   ) where  import Language.Haskell.TH hiding (cxt)-import Language.Haskell.TH.Syntax (VarBangType)+import Language.Haskell.TH.Syntax (VarBangType, Name(..), mkOccName, occString) import Data.String import Data.Foldable (foldl') import Barbies@@ -26,7 +29,23 @@ import Control.Applicative import Data.Functor.Identity (Identity(..)) import Data.Functor.Compose (Compose(..))+import Data.List.Split +-- | A pair of a getter and a setter+-- Not van Laarhoven to avoid dictionary passing+data LensB b a = LensB+  { viewB :: forall h. b h -> h a+  , setB :: forall h. h a -> b h -> b h+  }++getLensB :: Functor f => LensB b a -> (h a -> f (h a)) -> b h -> f (b h)+getLensB (LensB v s) f b = (\x -> s x b) <$> f (v b)+{-# INLINE getLensB #-}++class AccessorsB b where+  -- | A collection of lenses (getter-setter pairs)+  baccessors :: b (LensB b)+ -- | barbies doesn't care about field names, but they are useful in many use cases class FieldNamesB b where   -- | A collection of field names.@@ -56,8 +75,14 @@       varW <- newName "h"       let xs = varNames "x" fields       let ys = varNames "y" fields+      varB <- newName "b"       let transformed = transformCon varS varW con       let names = foldl' AppE (ConE conName) [AppE (ConE 'Const) $ AppE (VarE 'fromString) $ LitE $ StringL $ nameBase name | (name, _, _) <- fields]+          accessors = foldl' appE (conE conName)+            [ [|LensB+                $(varE name)+                (\ $(varP varW) $(varP varB) -> $(recUpdE (varE varB) [pure (name, VarE varW)])) |]+            | (name, _, _) <- fields]            -- Turn TyVarBndr into just a Name such that we can           -- reconstruct the constructor applied to already-present@@ -85,6 +110,7 @@             )           {-# INLINE bstrip #-}         instance FieldNamesB $(datC) where bfieldNames = $(pure names)+        instance AccessorsB $(datC) where baccessors = $(accessors)         instance FunctorB $(datC) where           bmap f $(conP conName $ map varP xs) = $(foldl'               appE@@ -95,7 +121,7 @@           bdistribute fb = $(foldl'               appE               (conE conName)-              [ [| Compose ($(varE fd) <$> fb) |] | (fd, _, _) <- fields ]+              [ [| Compose ($(varE (unmangle fd)) <$> fb) |] | (fd, _, _) <- fields ]             )         instance TraversableB $(datC) where           btraverse f $(conP conName $ map varP xs) = $(fst $ foldl'@@ -123,14 +149,14 @@     go d = pure [d]  varNames :: String -> [VarBangType] -> [Name]-varNames p vbt = [mkName (p ++ nameBase v) | (v, _, _) <- vbt]+varNames p vbt = [mkName (p ++ nameBase (unmangle v)) | (v, _, _) <- vbt]  transformCon :: Name -- ^ switch variable   -> Name -- ^ wrapper variable   -> Con -- ^ original constructor   -> Con transformCon switchName wrapperName (RecC name xs) = RecC name-  [(v, b, ConT ''Wear+  [(unmangle v, b, ConT ''Wear     `AppT` VarT switchName     `AppT` VarT wrapperName     `AppT` t)@@ -138,3 +164,15 @@   ] transformCon var w (ForallC tvbs cxt con) = ForallC tvbs cxt $ transformCon var w con transformCon _ _ con = error $ "transformCon: unsupported " ++ show con++-- | Unmangle record field names+--+-- When 'DuplicateRecordFields' is turned on, record field names are mangled.+-- (see https://gitlab.haskell.org/ghc/ghc/-/wikis/records/overloaded-record-fields/duplicate-record-fields#mangling-selector-names)+-- We undo that because these mangled field names don't round-trip through TH splices.+unmangle :: Name -> Name+unmangle (Name occ flavour) = Name occ' flavour+  where+    occ' = case wordsBy (== ':') (occString occ) of+        ["$sel", fd, _qual] -> mkOccName fd+        _ -> occ