diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for barbies-th +## 0.1.7 + +* `declareBareB` now generates deriving clauses for the bare type too +* It no longer adds `deriving Generic` unconditionally + +## 0.1.6 + +* Added a workaround to prevent exceeding the max arity of constraint tuples + ## 0.1.5 * It now generates `ConstraintsB` and `ApplicativeB` declarations without generics diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,7 +20,7 @@ data Foo sw h = Foo { foo :: Wear sw h Int, , bar :: Wear sw h String - } deriving Generic + } instance BareB Foo instance FieldNamesB (Foo Covered) where bfieldNames = Foo (Const "foo") (Const "bar") @@ -33,9 +33,34 @@ instance ProductBC (Foo Covered) ``` +Typically you need the following extensions to make `declareBareB` work: + +``` +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +``` + GHC sometimes takes very long time to compile code with generically derived instances, and it often fails to inline functions properly too. This package generates most instance methods by TH, reducing large amount of compilation time of the declarations and use sites. Unlike [higgledy](https://hackage.haskell.org/package/higgledy) which relies on in-memory representation using `GHC.Generic`, you don't have to worry about the performance, and you can benefit from various language features (e.g. -Wmissing-fields, `RecordWildCards` etc) even in higher-kinded form. + +Deriving pass-through +---- + +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)` + +generates + +``` +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) +``` diff --git a/barbies-th.cabal b/barbies-th.cabal --- a/barbies-th.cabal +++ b/barbies-th.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: barbies-th -version: 0.1.5 +version: 0.1.7 synopsis: Create strippable HKD via TH description: Please see Data.Barbie.TH bug-reports: https://github.com/fumieval/barbies-th diff --git a/src/Barbies/TH.hs b/src/Barbies/TH.hs --- a/src/Barbies/TH.hs +++ b/src/Barbies/TH.hs @@ -22,6 +22,7 @@ import Language.Haskell.TH.Syntax (VarBangType, Name(..), mkOccName, occString) import Data.String import Data.Foldable (foldl') +import Data.List (partition) import Barbies import Barbies.Constraints import Barbies.Bare @@ -71,18 +72,22 @@ decs' <- traverse go decs return $ concat decs' where - go (DataD _ dataName tvbs _ [con@(RecC conName fields)] classes) = do - varS <- newName "sw" - varW <- newName "h" + go (DataD _ dataName tvbs _ [con@(RecC nDataCon fields)] classes) = do + nSwitch <- newName "sw" + nWrap <- 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) + nData <- newName "b" + nConstr <- newName "c" + nX <- newName "x" + let transformed = transformCon nSwitch nWrap con + let reconE = foldl' appE (conE nDataCon) + -- field names for FieldNamesB + fieldNamesE = reconE [[|Const $ fromString $(litE $ StringL $ nameBase name)|] | (name, _, _) <- fields] + accessors = reconE [ [|LensB $(varE name) - (\ $(varP varW) $(varP varB) -> $(recUpdE (varE varB) [pure (name, VarE varW)])) |] + (\ $(varP nX) $(varP nData) -> $(recUpdE (varE nData) [pure (name, VarE nX)])) |] | (name, _, _) <- fields] -- Turn TyVarBndr into just a Name such that we can @@ -95,69 +100,66 @@ -- variables. vanillaType = foldl' appT (conT dataName) (varT . varName <$> tvbs) - types = [t | (_, _, t) <- fields] - - varCstr <- newName "c" + -- max arity = 62 + typeChunks = chunksOf 62 [varT nConstr `appT` pure t | (_, _, t) <- fields] + 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 decs <- [d| instance BareB $(vanillaType) where - bcover $(conP conName $ map varP xs) = $(foldl' - appE - (conE conName) - (appE (conE 'Identity) . varE <$> xs) - ) + bcover $(conP nDataCon $ map varP xs) + = $(reconE $ appE (conE 'Identity) . varE <$> xs) {-# INLINE bcover #-} - bstrip $(conP conName $ map varP xs) = $(foldl' - appE - (conE conName) - (appE (varE 'runIdentity) . varE <$> xs) - ) + bstrip $(conP nDataCon $ map varP xs) + = $(reconE $ appE (varE 'runIdentity) . varE <$> xs) {-# INLINE bstrip #-} - instance FieldNamesB $(datC) where bfieldNames = $(pure names) + instance FieldNamesB $(datC) where bfieldNames = $(fieldNamesE) instance AccessorsB $(datC) where baccessors = $(accessors) instance FunctorB $(datC) where - bmap f $(conP conName $ map varP xs) = $(foldl' - appE - (conE conName) - (appE (varE 'f) . varE <$> xs) - ) + bmap f $(conP nDataCon $ map varP xs) + = $(reconE (appE (varE 'f) . varE <$> xs)) instance DistributiveB $(datC) where - bdistribute fb = $(foldl' - appE - (conE conName) + bdistribute fb = $(reconE + -- TODO: NoFieldSelectors [ [| Compose ($(varE (unmangle fd)) <$> fb) |] | (fd, _, _) <- fields ] ) instance TraversableB $(datC) where - btraverse f $(conP conName $ map varP xs) = $(fst $ foldl' + btraverse f $(conP nDataCon $ map varP xs) = $(fst $ foldl' (\(l, op) r -> (infixE (Just l) (varE op) (Just r), '(<*>))) - (conE conName, '(<$>)) + (conE nDataCon, '(<$>)) (appE (varE 'f) . varE <$> xs) ) {-# INLINE btraverse #-} instance ConstraintsB $(datC) where - type AllB $(varT varCstr) $(datC) = $(foldl appT (tupleT (length types)) [varT varCstr `appT` pure t | t <- types]) - baddDicts $(conP conName $ map varP xs) = $(foldl' - (\r x -> [|$(r) (Pair Dict $(varE x))|]) - (conE conName) xs) + type AllB $(varT nConstr) $(datC) = $(allConstr) + baddDicts $(conP nDataCon $ map varP xs) + = $(reconE $ map (\x -> [|Pair Dict $(varE x)|]) xs) instance ApplicativeB $(datC) where - bpure x = $(foldl' - (\r _ -> [|$(r) x|]) - (conE conName) xs) - bprod $(conP conName $ map varP xs) $(conP conName $ map varP ys) = $(foldl' + bpure $(varP nX) = $(reconE $ varE nX <$ xs) + bprod $(conP nDataCon $ map varP xs) $(conP nDataCon $ map varP ys) = $(foldl' (\r (x, y) -> [|$(r) (Pair $(varE x) $(varE y))|]) - (conE conName) (zip xs ys)) + (conE nDataCon) (zip xs ys)) |] - drvs <- traverse (\cls -> - [d|deriving via Barbie $(datC) $(varT varW) - instance ($(cls) (Barbie $(datC) $(varT varW))) => $(cls) ($(datC) $(varT varW))|]) - [ pure t | DerivClause _ preds <- classes, t <- preds ] + -- 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) + instance ($(cls) (Barbie $(datC) $(varT nWrap))) => $(cls) ($(datC) $(varT nWrap))|]) + [ 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)|]) + [ (strat, pure t) | (_, DerivClause strat preds) <- classes', t <- preds ] return $ DataD [] dataName - (tvbs ++ [PlainTV varS, PlainTV varW]) + (tvbs ++ [PlainTV nSwitch, PlainTV nWrap]) Nothing [transformed] - [DerivClause Nothing [ConT ''Generic]] - : decs ++ concat drvs + [DerivClause Nothing $ concatMap fst classes'] + : decs ++ concat coverDrvs ++ bareDrvs go d = pure [d] varNames :: String -> [VarBangType] -> [Name] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS -ddump-splices #-} module Main where @@ -16,5 +15,5 @@ data Foo = Foo { foo :: Int , bar :: String - } deriving (Show, Eq) |] + } deriving (Show, Eq, Generic)|] main = pure ()