barbies-th 0.1.8 → 0.1.9

raw patch · 9 files changed

+210/−42 lines, 9 filesdep ~barbiesdep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: barbies, base, template-haskell

API changes (from Hackage documentation)

Files

• .gitignore +4/−0
• CHANGELOG.md +4/−0
• README.md +19/−3
• barbies-th.cabal +28/−7
• cabal.project +3/−0
• src/Barbies/TH.hs +67/−31
• src/Barbies/TH/Config.hs +36/−0
• tests/Main.hs +1/−1
• tests/passthrough.hs +48/−0

@@ -0,0 +1,4 @@+.stack-work/+*~+.ghc.environment.*+dist-newstyle/

@@ -1,5 +1,9 @@ # Revision history for barbies-th +## 0.1.9++* Added `passthroughBareB`+ ## 0.1.8  * `declareBareB` can now generate nested barbies when multiple data declarations are passed (#7)

@@ -33,9 +33,21 @@ instance ProductBC (Foo Covered) ``` -Typically you need the following extensions to make `declareBareB` work:+`passthroughBareB` generates a type synonym for the bare type,+preserving the semantics of the original definition. +```haskell+data FooB sw h = Foo+    { foo :: Wear sw h Int,+    , bar :: Wear sw h String+    }+type Foo = Foo Bare Identity+type FooH = Foo Covered ```++Typically you need the following extensions to make `declareBareB` work:++```haskell {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}@@ -54,16 +66,20 @@ stock deriving does not work on HKDs. Instead, it transforms deriving clauses into standalone ones via the `Barbie` wrapper, as well as ones for the `Bare` counterpart. For example, -`data Foo = ... deriving (Show, Eq)`+```haskell+data Foo = ... deriving (Show, Eq)+```  generates -```+```haskell deriving instance Show (Foo Bare Identity) deriving instance Eq (Foo Bare Identity) deriving via Barbie (Foo Covered) h instance Show (Barbie (Foo Covered) h) => Show (Foo Covered h) deriving via Barbie (Foo Covered) h instance Eq (Barbie (Foo Covered) h) => Eq (Foo Covered h) ```++Note that `Barbies` module must be imported manually in order to make use of coercions.  Matryoshka barbies ----

@@ -1,24 +1,34 @@ cabal-version:       2.4 name:                barbies-th-version:             0.1.8+version:             0.1.9 synopsis:            Create strippable HKD via TH description:         Please see Data.Barbie.TH-bug-reports:         https://github.com/fumieval/barbies-th+homepage:            https://github.com/fumieval/barbies-th+bug-reports:         https://github.com/fumieval/barbies-th/issues license:             BSD-3-Clause license-file:        LICENSE author:              Fumiaki Kinoshita maintainer:          fumiexcel@gmail.com-copyright:           Copyright (c) 2020 Fumiaki Kinoshita-category:            Data, Generics-extra-source-files:  CHANGELOG.md, README.md+copyright:           Copyright (c) 2021 Fumiaki Kinoshita+category:            Data, Generics, Data Structures+extra-source-files:+  CHANGELOG.md+  README.md+  cabal.project+  .gitignore +source-repository head+  type: git+  location: https://github.com/fumieval/barbies-th.git+ library   exposed-modules:     Barbies.TH+    Barbies.TH.Config     Data.Barbie.TH   other-extensions:    RankNTypes, PolyKinds, DataKinds, KindSignatures, TemplateHaskell, TypeFamilies-  build-depends:       base >= 4.12-    , template-haskell >= 2.14 && <2.17+  build-depends:       base >= 4.12 && <4.17+    , template-haskell >= 2.14 && <2.18     , barbies ^>= 2.0.1     , split ^>= 0.2   hs-source-dirs:      src@@ -28,6 +38,17 @@ test-suite th   type: exitcode-stdio-1.0   main-is: Main.hs+  hs-source-dirs:+      tests+  build-depends:+      base >=4.7 && <5+    , barbies+    , barbies-th+  default-language: Haskell2010++test-suite th-passthrough+  type: exitcode-stdio-1.0+  main-is: passthrough.hs   hs-source-dirs:       tests   build-depends:

@@ -0,0 +1,3 @@+packages: .+allow-newer:+  split:base

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-}@@ -12,12 +13,16 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-} module Barbies.TH (FieldNamesB(..)   , LensB(..)   , getLensB   , AccessorsB(..)   , declareBareB+  , declareBareBWith   , declareBareBWithOtherBarbies+  , passthroughBareB   ) where  import Language.Haskell.TH hiding (cxt)@@ -28,14 +33,14 @@ import Barbies import Barbies.Constraints import Barbies.Bare+import Barbies.TH.Config import Data.Functor.Product import GHC.Generics (Generic) import Control.Applicative import Data.Functor.Identity (Identity(..)) import Data.Functor.Compose (Compose(..)) import Data.List.Split-import Data.Maybe (mapMaybe)-import Data.Bool (bool)+import Data.Maybe  -- | A pair of a getter and a setter -- Not van Laarhoven to avoid dictionary passing@@ -48,10 +53,12 @@ nestLensB l (LensB lv ls) =   LensB (lv . snd . l) (\n h -> let (s, x) = l h in s (ls n x)) +-- | Obtain a van-laarhoven lens (compatible with the lens library) from 'LensB' 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 #-} +-- | The class of higher-kinded datatypes where lenses can be defined class AccessorsB b where   -- | A collection of lenses (getter-setter pairs)   baccessors :: b (LensB b)@@ -75,18 +82,29 @@ -- @data User t f = User { uid :: Wear t f Int, name :: Wear t f String }@ -- declareBareB :: DecsQ -> DecsQ-declareBareB = declareBareBWithOtherBarbies []+declareBareB = declareBareBWith classic +-- | Defines a synonym for the bare type with the same name.+-- The strippable definition is suffixed by B, and the covered type is suffixed by H.+passthroughBareB :: DecsQ -> DecsQ+passthroughBareB = declareBareBWith passthrough+ -- | Like 'declareBareB' except that one can specify the 'Name's of other -- barbies. Members with these types won't be wrapped with 'Wear'. declareBareBWithOtherBarbies :: [Name] -> DecsQ -> DecsQ-declareBareBWithOtherBarbies friends decsQ = do+declareBareBWithOtherBarbies xs = declareBareBWith classic { friends = xs }++-- | Generate a higher-kinded data declaration using a custom config+declareBareBWith :: DeclareBareBConfig -> DecsQ -> DecsQ+declareBareBWith DeclareBareBConfig{..} decsQ = do   decs <- decsQ-  let newTypeNames = dataDecNames decs-  decs' <- traverse (go (newTypeNames <> friends)) decs+  let otherBarbieNames = [ (k, mkName $ barbieName $ nameBase k) | k <- dataDecNames decs ]+          ++ map (\x -> (x, x)) friends+  decs' <- traverse (go otherBarbieNames) decs   return $ concat decs'   where-    go otherBarbieNames (DataD _ dataName tvbs _ [con@(RecC nDataCon mangledfields)] classes) = do+    go otherBarbieNames (DataD _ dataName0 tvbs _ [con@(RecC nDataCon mangledfields)] classes) = do+      let dataName = mkName $ barbieName $ nameBase dataName0       let fields = [(unmangle name, c, t) | (name, c, t) <- mangledfields]       nSwitch <- newName "sw"       nWrap <- newName "h"@@ -95,12 +113,12 @@       -- 'mapMembers' applies one of two functions to elements of a list       -- according to whether or not they align with another barbie       let otherBarbieMask = [ case t of-                                ConT n | n `elem` otherBarbieNames -> True-                                _ -> False+                                ConT n | Just v <- lookup n otherBarbieNames -> Just v+                                _ -> Nothing                             | (_, _, t) <- fields                             ]       let mapMembers :: (b -> c) -> (b -> c) -> [b] -> [c]-          mapMembers normal otherBarbie = zipWith (bool normal otherBarbie) otherBarbieMask+          mapMembers normal otherBarbie = zipWith (maybe normal (const otherBarbie)) otherBarbieMask       nData <- newName "b"       nConstr <- newName "c"       nX <- newName "x"@@ -109,7 +127,7 @@           -- field names for FieldNamesB           fieldNamesE = reconE $ mapMembers             (\(name,_,_) -> [|Const $ fromString $(litE $ StringL $ nameBase name)|])-            (const [|bfieldNames|])+            (\_ -> [|bfieldNames|])             fields           accessors = reconE $ mapMembers             (\name -> [|LensB@@ -132,25 +150,36 @@           -- Turn TyVarBndr into just a Name such that we can           -- reconstruct the constructor applied to already-present           -- type variables below.+#if MIN_VERSION_template_haskell(2,17,0)+          varName (PlainTV n _) = n+          varName (KindedTV n _ _) = n+#else           varName (PlainTV n) = n           varName (KindedTV n _) = n+#endif            -- The type name as present originally along with its type           -- variables.           vanillaType = foldl' appT (conT dataName) (varT . varName <$> tvbs) -          -- max arity = 62-          typeChunks = chunksOf 62 (mapMembers-              (\t -> varT nConstr `appT` t)-              (\t -> [t| AllB $(varT nConstr) ($t Covered)|])-              [pure t | (_, _, t) <- fields]-            )+      -- bare/covered types+      bareType <- [t| $(vanillaType) Bare Identity |]+      coveredType <- [t| $(vanillaType) Covered |]++      -- max arity = 62+      let typeChunks = chunksOf 62+            [ case mask of+              Just t' -> [t| AllB $(varT nConstr) ($(conT t') Covered)|]+              Nothing -> varT nConstr `appT` pure t+            | ((_, _, t), mask) <- zip fields otherBarbieMask+            ]           mkConstraints ps = foldl appT (tupleT $ length ps) ps           allConstr = case typeChunks of             [ps] -> mkConstraints ps             pss -> mkConstraints $ map mkConstraints pss -      let datC = vanillaType `appT` conT ''Covered++      let datC = pure coveredType       decs <- [d|         instance BareB $(vanillaType) where           bcover $(conP nDataCon $ map varP xs)@@ -159,12 +188,12 @@           bstrip $(conP nDataCon $ map varP xs)             = $(reconE $ mapMembers (appE (varE 'runIdentity)) (appE (varE 'bstrip)) (varE <$> xs))           {-# INLINE bstrip #-}-        instance FieldNamesB $(datC) where bfieldNames = $(fieldNamesE)-        instance AccessorsB $(datC) where baccessors = $(accessors)-        instance FunctorB $(datC) where+        instance FieldNamesB $(pure coveredType) where bfieldNames = $(fieldNamesE)+        instance AccessorsB $(pure coveredType) where baccessors = $(accessors)+        instance FunctorB $(pure coveredType) where           bmap f $(conP nDataCon $ map varP xs)             = $(reconE (mapMembers (appE (varE 'f)) (appE [|bmap f|]) (varE <$> xs)))-        instance DistributiveB $(datC) where+        instance DistributiveB $(pure coveredType) where           bdistribute fb = $(reconE $               -- TODO: NoFieldSelectors               mapMembers@@ -172,22 +201,22 @@                 (\fd -> [| bdistribute ($fd <$> fb) |])                 [varE fd | (fd, _, _) <- fields]             )-        instance TraversableB $(datC) where+        instance TraversableB $(pure coveredType) where           btraverse f $(conP nDataCon $ map varP xs) = $(fst $ foldl'               (\(l, op) r -> (infixE (Just l) (varE op) (Just r), '(<*>)))               (conE nDataCon, '(<$>))               (mapMembers (appE (varE 'f)) (\x -> [|btraverse f $x|]) (varE <$> xs))             )           {-# INLINE btraverse #-}-        instance ConstraintsB $(datC) where-          type AllB $(varT nConstr) $(datC) = $(allConstr)+        instance ConstraintsB $(pure coveredType) where+          type AllB $(varT nConstr) $(pure coveredType) = $(allConstr)           baddDicts $(conP nDataCon $ map varP xs)             = $(reconE $ mapMembers                  (\x -> [|Pair Dict $x|])                  (\x -> [|baddDicts $x|])                  (varE <$> xs)                )-        instance ApplicativeB $(datC) where+        instance ApplicativeB $(pure coveredType) where           bpure $(varP nX) = $(reconE $ mapMembers                                  (const (varE nX))                                  (const [|bpure $(varE nX)|])@@ -195,13 +224,14 @@                               )           bprod $(conP nDataCon $ map varP xs) $(conP nDataCon $ map varP ys) = $(foldl'             (\r (isOtherBarbie, x, y) ->-              if isOtherBarbie+              if isJust isOtherBarbie                 then [|$r (bprod $(varE x) $(varE y))|]                 else [|$r (Pair $(varE x) $(varE y))|])             (conE nDataCon) (zip3 otherBarbieMask xs ys))         |]       -- strip deriving Generic       let classes' = map (\(DerivClause strat cs) -> fmap (DerivClause strat) $ partition (== ConT ''Generic) cs) classes+       -- For the covered type, derive instances via 'Barbie' wrapper instead.       coverDrvs <- traverse (\cls ->         [d|deriving via Barbie $(datC) $(varT nWrap)@@ -209,14 +239,20 @@         [ pure t | (_, DerivClause _ preds) <- classes', t <- preds ]       -- Redefine instances of the bare type with the original strategy       bareDrvs <- traverse (\(strat, cls) ->-        standaloneDerivWithStrategyD strat (pure []) [t|$(cls) ($(vanillaType) Bare Identity)|])+        standaloneDerivWithStrategyD strat (pure []) [t|$(cls) $(pure bareType)|])         [ (strat, pure t) | (_, DerivClause strat preds) <- classes', t <- preds ]       return $ DataD [] dataName+#if MIN_VERSION_template_haskell(2,17,0)+        (tvbs ++ [PlainTV nSwitch (), PlainTV nWrap ()])+#else         (tvbs ++ [PlainTV nSwitch, PlainTV nWrap])+#endif         Nothing         [transformed]         [DerivClause Nothing $ concatMap fst classes']         : decs ++ concat coverDrvs ++ bareDrvs+        ++ [ TySynD (mkName name) tvbs bareType | name <- maybeToList $ bareName $ nameBase dataName0]+        ++ [ TySynD (mkName name) tvbs coveredType | name <- maybeToList $ coveredName $ nameBase dataName0]     go _ d = pure [d]  dataDecNames :: [Dec] -> [Name]@@ -230,7 +266,7 @@ varNames :: String -> [VarBangType] -> [Name] varNames p vbt = [mkName (p ++ nameBase v) | (v, _, _) <- vbt] -transformCon :: [Name] -- ^ Names of other barbies+transformCon :: [(Name, Name)] -- ^ Names of other barbies   -> Name -- ^ switch variable   -> Name -- ^ wrapper variable   -> Con -- ^ original constructor@@ -241,8 +277,8 @@   | (v, b, t) <- xs   , let     t' = case t of-      ConT n | n `elem` otherBarbieNames ->-        ConT n `AppT` VarT switchName `AppT` VarT wrapperName+      ConT n | Just n' <- lookup n otherBarbieNames ->+        ConT n' `AppT` VarT switchName `AppT` VarT wrapperName       _ -> ConT ''Wear `AppT` VarT switchName `AppT` VarT wrapperName `AppT` t   ] transformCon otherBarbieNames var w (ForallC tvbs cxt con) =

@@ -0,0 +1,36 @@+module Barbies.TH.Config+  ( DeclareBareBConfig(..)+  , classic+  , passthrough+  ) where+import Language.Haskell.TH++-- | Keep it in a separate module until NoFieldSelectors gets widespread+data DeclareBareBConfig = DeclareBareBConfig+  { friends :: [Name] -- ^ Members with these types won't be wrapped with 'Wear'+  , bareName :: String -> Maybe String+  -- ^ generate a type synonym for the 'Barbies.Bare.Bare' type?+  , coveredName :: String -> Maybe String+  -- ^ generate a type synonym for the 'Barbies.Bare.Covered' type?+  , barbieName :: String -> String+  -- ^ modify the name of the datatype+  }++-- | Does not define any type synonyms+classic :: DeclareBareBConfig+classic = DeclareBareBConfig+  { friends = []+  , bareName = const Nothing+  , coveredName = const Nothing+  , barbieName = id+  }++-- | Defines a synonym for the bare type with the same name.+-- The strippable definition is suffixed by B, and the covered type is suffixed by H.+passthrough :: DeclareBareBConfig+passthrough = DeclareBareBConfig+  { friends = []+  , bareName = Just+  , coveredName = Just . (++"H")+  , barbieName = (++"B")+  }

@@ -19,7 +19,7 @@     { foo :: Int     , bar :: String     } deriving (Show, Eq, Generic)|]- + declareBareB [d|   data Inner = Inner     { inner :: Int

@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS -ddump-splices #-}+module Main where+import Barbies.TH+import GHC.Generics+import Barbies+import Barbies.Bare+import Data.Functor.Identity++passthroughBareB [d|+  data Foo = Foo+    { foo :: Int+    , bar :: String+    } deriving (Show, Eq, Generic)|]++passthroughBareB [d|+  data Inner = Inner+    { inner :: Int+    } deriving (Show, Eq, Generic)+  data Outer = Outer+    { outer :: Inner+    , other :: Bool+    } deriving (Show, Eq, Generic)+    |]++test_con :: FooH []+test_con = Foo+  { foo = [0]+  , bar = ["Haskell"]+  }++test_bare :: Inner+test_bare = Inner 0 :: InnerB Bare Identity++test_sel :: ([Int], [String])+test_sel = (foo test_con, bar test_con)++test_upd :: FooH []+test_upd = test_con { foo = [], bar = [] }++main = pure ()+