recollections 0.1.0.0 → 0.1.1.0

raw patch · 24 files changed

+1151/−80 lines, 24 filesdep +adjunctionsdep +distributivedep +tasty-benchPVP ok

version bump matches the API change (PVP)

Dependencies added: adjunctions, distributive, tasty-bench

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +80/−3
• bench/Bench.hs +35/−0
• bench/Breadth/B16.hs +35/−0
• bench/Breadth/B4.hs +23/−0
• bench/Breadth/B64.hs +83/−0
• bench/Depth/D1.hs +21/−0
• bench/Depth/D2.hs +21/−0
• bench/Depth/D3.hs +21/−0
• bench/Depth/D4.hs +21/−0
• bench/Depth/D5.hs +21/−0
• bench/Depth/D6.hs +21/−0
• bench/Depth/D7.hs +21/−0
• bench/Depth/D8.hs +21/−0
• bench/Leaf.hs +17/−0
• recollections.cabal +67/−1
• src/Data/Recollections/TH.hs +423/−70
• test-kmettoverse/Aliased.hs +30/−0
• test-kmettoverse/Kmettoverse.hs +52/−0
• test-kmettoverse/Nested/Inner.hs +23/−0
• test-kmettoverse/Nested/Outer.hs +32/−0
• test/Nested/Inner.hs +24/−0
• test/Nested/Outer.hs +28/−0
• test/Spec.hs +23/−6

@@ -6,6 +6,14 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 0.1.1.0 - 2026-10-04++- Added `mkDistributive` and `mkRepresentable` instance generators.+  With `mkDistributiveFor` and `mkRepresentableFor` variants for aliased imports.+- Added nested collections.+  * A tag constructor may wrap the tag type of a collection from another module.+  * `mkBounded` and `mkEnum` generate tag instances that work with nested tags.+ ## 0.1.0.0 - 2026-07-26  Initial release.

@@ -37,12 +37,86 @@ mkIndices ''Things ``` +## Nesting++A constructor may wrap the tag type of another collection.+The field then holds that whole collection:++```haskell+import Some qualified++data Tag+  = Something Some.Tag+  | Local+  deriving (Eq, Ord, Show)++mkCollection ''Tag++-- data Collection a = Collection+--   { something :: Some.Collection a+--   , local :: a+--   }+```++The nested collection is looked up in the module defining `Some.Tag`, so the+nested tag and its splices must live together in their own module (and be+exported from it). Every collection generator spliced for the outer tag needs+its counterpart spliced for the nested one. The class instance generators+delegate to the nested instances instead, so `mkDistributive` and+`mkRepresentable` need the same instances for `Some.Collection`.++Stock `Enum` and `Bounded` can't be derived for such tags, so there are+generators that number the nested tags in place:++```haskell+mkBounded ''Tag+mkEnum ''Tag -- needs Bounded Tag, plus Enum and Bounded Some.Tag++-- [minBound .. maxBound] == toList indices+```++## Kmettoverse++With `adjunctions` and `distributive` in the dependencies of the splicing package+(`recollections` itself doesn't depend on them), the classes can be instantiated directly:++```haskell+{-# LANGUAGE TypeFamilies #-}++import Data.Distributive (Distributive(..))+import Data.Functor.Rep (Representable(..))++mkDistributive ''Things+mkRepresentable ''Things++-- instance Distributive Collection where ...+-- instance Representable Collection where+--   type Rep Collection = Things+--   ...+```++`Representable` requires the `Distributive` instance, so both splices are needed.++The classes are looked up in the splicing module scope, by their plain or module-qualified names.+When the modules are imported under an alias, pass the class names explicitly:++```haskell+import qualified Data.Distributive as D+import qualified Data.Functor.Rep as R++mkDistributiveFor ''D.Distributive ''Things+mkRepresentableFor ''R.Representable ''Things+```+ ## Kmettoverse-lite +Without the extra dependencies, the methods can be generated as top-level functions instead.+Those names clash with the class imports above.+ ```haskell -- Distributive mkDistribute ''Things--- collect is +-- collect is `distribute . fmap f`  -- Representable mkIndex ''Things@@ -58,8 +132,11 @@  ## Gotchas -All the constructors of the tag type must be nullary — anything else is a-compile-time error, since a partial `Collection` would make `index` partial too.+All the constructors of the tag type must be nullary or wrap a single nested+tag type — anything else is a compile-time error, since a partial `Collection`+would make `index` partial too.  The generated names (`Collection`, `indices`, `distribute`, `index`, `tabulate`) are fixed, so a tag named e.g. `Index` will clash with them.+For the same reason, a module with nested collections must be imported+qualified, or its generated names become ambiguous with the outer ones.

@@ -0,0 +1,35 @@+module Main (main) where++import Breadth.B4 qualified as Breadth4+import Breadth.B16 qualified as Breadth16+import Breadth.B64 qualified as Breadth64+import Depth.D1 qualified as Depth1+import Depth.D2 qualified as Depth2+import Depth.D4 qualified as Depth4+import Depth.D8 qualified as Depth8+import Data.Foldable (foldl', toList)+import Test.Tasty.Bench++main :: IO ()+main = defaultMain+  [ bgroup "breadth"+      [ bgroup "4" $ cases Breadth4.indices+      , bgroup "16" $ cases Breadth16.indices+      , bgroup "64" $ cases Breadth64.indices+      ]+  , bgroup "depth"+      [ bgroup "1" $ cases Depth1.indices+      , bgroup "2" $ cases Depth2.indices+      , bgroup "4" $ cases Depth4.indices+      , bgroup "8" $ cases Depth8.indices+      ]+  ]++cases :: forall f t. (Foldable f, Enum t) => f t -> [Benchmark]+cases collection =+  [ bench "fromEnum" $ whnf (foldl' (\acc t -> acc + fromEnum t) 0) tags+  , bench "toEnum" $ whnf (foldl' (\acc i -> toEnum @t i `seq` acc + 1) (0 :: Int)) ints+  ]+  where+    tags = toList collection+    ints = [0 .. length tags - 1]

@@ -0,0 +1,35 @@+{-# LANGUAGE TemplateHaskell #-}++module Breadth.B16+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+import Leaf qualified++data Tag+  = N0 Leaf.Tag+  | N1 Leaf.Tag+  | N2 Leaf.Tag+  | N3 Leaf.Tag+  | N4 Leaf.Tag+  | N5 Leaf.Tag+  | N6 Leaf.Tag+  | N7 Leaf.Tag+  | N8 Leaf.Tag+  | N9 Leaf.Tag+  | N10 Leaf.Tag+  | N11 Leaf.Tag+  | N12 Leaf.Tag+  | N13 Leaf.Tag+  | N14 Leaf.Tag+  | N15 Leaf.Tag+  | End++mkCollection ''Tag+mkIndices ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}++module Breadth.B4+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+import Leaf qualified++data Tag+  = N0 Leaf.Tag+  | N1 Leaf.Tag+  | N2 Leaf.Tag+  | N3 Leaf.Tag+  | End++mkCollection ''Tag+mkIndices ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,83 @@+{-# LANGUAGE TemplateHaskell #-}++module Breadth.B64+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+import Leaf qualified++data Tag+  = N0 Leaf.Tag+  | N1 Leaf.Tag+  | N2 Leaf.Tag+  | N3 Leaf.Tag+  | N4 Leaf.Tag+  | N5 Leaf.Tag+  | N6 Leaf.Tag+  | N7 Leaf.Tag+  | N8 Leaf.Tag+  | N9 Leaf.Tag+  | N10 Leaf.Tag+  | N11 Leaf.Tag+  | N12 Leaf.Tag+  | N13 Leaf.Tag+  | N14 Leaf.Tag+  | N15 Leaf.Tag+  | N16 Leaf.Tag+  | N17 Leaf.Tag+  | N18 Leaf.Tag+  | N19 Leaf.Tag+  | N20 Leaf.Tag+  | N21 Leaf.Tag+  | N22 Leaf.Tag+  | N23 Leaf.Tag+  | N24 Leaf.Tag+  | N25 Leaf.Tag+  | N26 Leaf.Tag+  | N27 Leaf.Tag+  | N28 Leaf.Tag+  | N29 Leaf.Tag+  | N30 Leaf.Tag+  | N31 Leaf.Tag+  | N32 Leaf.Tag+  | N33 Leaf.Tag+  | N34 Leaf.Tag+  | N35 Leaf.Tag+  | N36 Leaf.Tag+  | N37 Leaf.Tag+  | N38 Leaf.Tag+  | N39 Leaf.Tag+  | N40 Leaf.Tag+  | N41 Leaf.Tag+  | N42 Leaf.Tag+  | N43 Leaf.Tag+  | N44 Leaf.Tag+  | N45 Leaf.Tag+  | N46 Leaf.Tag+  | N47 Leaf.Tag+  | N48 Leaf.Tag+  | N49 Leaf.Tag+  | N50 Leaf.Tag+  | N51 Leaf.Tag+  | N52 Leaf.Tag+  | N53 Leaf.Tag+  | N54 Leaf.Tag+  | N55 Leaf.Tag+  | N56 Leaf.Tag+  | N57 Leaf.Tag+  | N58 Leaf.Tag+  | N59 Leaf.Tag+  | N60 Leaf.Tag+  | N61 Leaf.Tag+  | N62 Leaf.Tag+  | N63 Leaf.Tag+  | End++mkCollection ''Tag+mkIndices ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module Depth.D1+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+import Leaf qualified as Lower++data Tag+  = First+  | Down Lower.Tag+  | Last++mkCollection ''Tag+mkIndices ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module Depth.D2+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+import Depth.D1 qualified as Lower++data Tag+  = First+  | Down Lower.Tag+  | Last++mkCollection ''Tag+mkIndices ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module Depth.D3+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+import Depth.D2 qualified as Lower++data Tag+  = First+  | Down Lower.Tag+  | Last++mkCollection ''Tag+mkIndices ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module Depth.D4+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+import Depth.D3 qualified as Lower++data Tag+  = First+  | Down Lower.Tag+  | Last++mkCollection ''Tag+mkIndices ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module Depth.D5+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+import Depth.D4 qualified as Lower++data Tag+  = First+  | Down Lower.Tag+  | Last++mkCollection ''Tag+mkIndices ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module Depth.D6+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+import Depth.D5 qualified as Lower++data Tag+  = First+  | Down Lower.Tag+  | Last++mkCollection ''Tag+mkIndices ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module Depth.D7+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+import Depth.D6 qualified as Lower++data Tag+  = First+  | Down Lower.Tag+  | Last++mkCollection ''Tag+mkIndices ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module Depth.D8+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+import Depth.D7 qualified as Lower++data Tag+  = First+  | Down Lower.Tag+  | Last++mkCollection ''Tag+mkIndices ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}++module Leaf+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Recollections.TH+import GHC.Generics+++data Tag = A | B | C | D+  deriving (Enum, Bounded)++mkCollection ''Tag+mkIndices ''Tag

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           recollections-version:        0.1.0.0+version:        0.1.1.0 synopsis:       Fixed-size representable (Zippy Applicative) collections. category:       Data Structures author:         IC Rainbow@@ -44,10 +44,40 @@     , template-haskell >=2.20   default-language: GHC2021 +test-suite recollections-kmettoverse+  type: exitcode-stdio-1.0+  main-is: Kmettoverse.hs+  other-modules:+      Aliased+      Nested.Inner+      Nested.Outer+      Paths_recollections+  autogen-modules:+      Paths_recollections+  hs-source-dirs:+      test-kmettoverse+  default-extensions:+      StrictData+      LambdaCase+      ApplicativeDo+      BlockArguments+      DerivingStrategies+      DerivingVia+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      adjunctions+    , base >=4.18 && <5+    , distributive+    , recollections+    , template-haskell >=2.20+  default-language: GHC2021+ test-suite recollections-test   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Nested.Inner+      Nested.Outer       Paths_recollections   autogen-modules:       Paths_recollections@@ -64,5 +94,41 @@   build-depends:       base >=4.18 && <5     , recollections+    , template-haskell >=2.20+  default-language: GHC2021++benchmark recollections-bench+  type: exitcode-stdio-1.0+  main-is: Bench.hs+  other-modules:+      Breadth.B16+      Breadth.B4+      Breadth.B64+      Depth.D1+      Depth.D2+      Depth.D3+      Depth.D4+      Depth.D5+      Depth.D6+      Depth.D7+      Depth.D8+      Leaf+      Paths_recollections+  autogen-modules:+      Paths_recollections+  hs-source-dirs:+      bench+  default-extensions:+      StrictData+      LambdaCase+      ApplicativeDo+      BlockArguments+      DerivingStrategies+      DerivingVia+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -fproc-alignment=64+  build-depends:+      base >=4.18 && <5+    , recollections+    , tasty-bench     , template-haskell >=2.20   default-language: GHC2021

@@ -2,31 +2,79 @@ {-# LANGUAGE TemplateHaskellQuotes #-}  module Data.Recollections.TH-  ( mkCollection+  (  -- * Collections generator+    mkCollection   , mkIndices +    -- * Distributive+    -- $distributive+  , mkDistributive+  , mkDistributiveFor   , mkDistribute +    -- * Representable+    -- $representable+  , mkRepresentable+  , mkRepresentableFor   , mkIndex   , mkTabulate++    -- * Tag instances+    -- $tagInstances+  , mkBounded+  , mkEnum   ) where  import Data.Char import Data.Foldable import Data.Traversable+import GHC.Enum (boundedEnumFrom, boundedEnumFromThen) import GHC.Generics (Generic, Generic1, Generically1) import Language.Haskell.TH+import Language.Haskell.TH.Syntax (mkNameG_tc, mkNameG_v) +{- | Generate a @Collection a@ type from a enum-like type.++Every constructor is represented by a field.+Reserved words like @type@ get a @'@ suffix.'++> data Things = This | That+>   deriving (Eq, Ord, Show, Enum, Bounded)+>+> mkCollection ''Things+>+> -- resulting splice+> data Collection a = Collection { this, that :: a }+>   deriving (Eq, Show, Generic, Generic1, Functor, Foldable, Traversable)+>   deriving Applicative via (Generically1 Collection)++A constructor may wrap the tag type of another collection, generated in the module that defines that tag.+The field then holds that whole collection:++> import Some qualified+>+> data Tag = Something Some.Tag | Local+>+> mkCollection ''Tag+>+> -- resulting splice+> data Collection a = Collection { something :: Some.Collection a, local :: a }++Every other collection generator applied to a nested tag requires the same generator in the nested module.+The instance generators call the nested instances instead, so the nested module needs the same instance generators.+-} mkCollection :: Name -> Q [Dec] mkCollection tags = do   let nothingsBanger = bang noSourceUnpackedness noSourceStrictness-  let collectionName = mkName "Collection"    names <- tagNames tags-  let-    fields = do-      name <- names-      pure $ varBangType (mkName $ fieldNameOf name) $ (bangType nothingsBanger) (varT (mkName "a"))+  fields <- for names \tag -> do+    fieldType <- case tag of+      Leaf _ -> pure $ varT (mkName "a")+      Nested _ sub -> do+        subCollection <- siblingOf mkNameG_tc "Collection" sub+        pure $ conT subCollection `appT` varT (mkName "a")+    pure $ varBangType (mkName . fieldNameOf $ tagName tag) $ bangType nothingsBanger fieldType   let constr = recC collectionName fields   let     derivs =@@ -57,134 +105,439 @@ collectionTyVar = PlainTV (mkName "a") () #endif +{- | Generate a value filled with the indices matching the fields.++> indices :: Collection Things+> indices = Collection { this = This, that = That }++This is useful with the Applicative instance to provide indexed operations:++> indexed c :: Collection a -> Collection (Things, a)+> indexed c = (,) <$> indices <*> c+-} mkIndices :: Name -> Q [Dec] mkIndices tags = do-  let collectionName = mkName "Collection"   let indicesName = mkName "indices"   names <- tagNames tags   sig <- sigD indicesName $ conT collectionName `appT` conT tags-  let body = foldl' appE (conE collectionName) (map (conE . mkName) names)+  fields <- for names \case+    Leaf name -> pure . conE $ mkName name+    Nested name sub -> do+      subIndices <- siblingOf mkNameG_v "indices" sub+      pure $ appE (appE (varE 'fmap) (conE $ mkName name)) (varE subIndices)+  let body = foldl' appE (conE collectionName) fields   fun <- funD indicesName [ clause [] (normalB body) [] ]   pure [sig, fun]  -- * Distributive -{- |-@-distribute f = Collection-  { this      = this      <$> f-  , that      = that      <$> f-  , something = something <$> f-  , else'     = else'     <$> f-  , entirely  = entirely  <$> f-  }-@+{- $distributive++<https://hackage-content.haskell.org/package/distributive-0.6.3/docs/Data-Distributive.html>++The instance generators need the @distributive@ package as a dependency of the splicing package,+not of @recollections@.+The class is looked up in the splicing module scope, so it has to be imported there. -}++{- | Generate a Distributive instance.++The splicing module must import "Data.Distributive", unqualified or qualified without an alias.+Use 'mkDistributiveFor' when the module is imported under an alias.++> instance Distributive Collection where+>   distribute f = Collection+>     { this = this <$> f+>     , that = that <$> f+>     }+-}+mkDistributive :: Name -> Q [Dec]+mkDistributive tags = do+  distributive <- lookupClass "Data.Distributive" "Distributive"+  mkDistributiveFor distributive tags++{- | Generate a Distributive instance for the explicitly provided class name.++> import qualified Data.Distributive as D+>+> mkDistributiveFor ''D.Distributive ''Things+-}+mkDistributiveFor :: Name -> Name -> Q [Dec]+mkDistributiveFor distributive tags = do+  names <- tagNames tags+  distributeName <- classMember mkNameG_v distributive "distribute"+  pure <$> instanceD (cxt []) (conT distributive `appT` conT collectionName)+    [ funD distributeName [distributeClause (const $ pure distributeName) names]+    , inlineP distributeName+    ]++{- | Generate a dual of sequenceA.++Doesn't need the @distributive@ package, but clashes with the "Data.Distributive" import.++> distribute :: Functor f => f (Collection a) -> Collection (f a)+> distribute f = Collection+>   { this      = this      <$> f+>   , that      = that      <$> f+>   , something = something <$> f+>   , else'     = else'     <$> f+>   , entirely  = entirely  <$> f+>   }+-} mkDistribute :: Name -> Q [Dec] mkDistribute tags = do-  let collectionName = mkName "Collection"   let distributeName = mkName "distribute"   names <- tagNames tags   let f = mkName "f"   let a = mkName "a"-  {- The binder must not shadow any field selector the body refers to by-     'mkName' (those are resolved lexically, by occurrence name). Field names-     always start with a lowercase letter, so a leading underscore is safe;-     plain @f@ would break for a tag named @F@. -}-  arg <- newName "_f"   sig <- sigD distributeName $     forallT [] (cxt [conT ''Functor `appT` varT f]) $       appT (appT arrowT (varT f `appT` (conT collectionName `appT` (varT a)))) $         (conT collectionName `appT` (varT f `appT` varT a))-  let-    body =-      foldl' appE (conE collectionName) do-        name <- names-        let fieldSelector = varE . mkName $ fieldNameOf name-        pure $ appE (varE 'fmap) fieldSelector `appE` varE arg-  fun <- funD distributeName-    [ clause [varP arg] (normalB body) []-    ]+  fun <- funD distributeName [distributeClause (siblingOf mkNameG_v "distribute") names]   inl <- inlineP distributeName   pure [sig, fun, inl] +distributeClause :: (Name -> Q Name) -> [Tag] -> Q Clause+distributeClause nested names = do+  {- The binder must not shadow any field selector the body refers to by+     'mkName' (those are resolved lexically, by occurrence name). Field names+     always start with a lowercase letter, so a leading underscore is safe;+     plain @f@ would break for a tag named @F@. -}+  arg <- newName "_f"+  fields <- for names \tag -> do+    let projected = appE (varE 'fmap) (varE . mkName . fieldNameOf $ tagName tag) `appE` varE arg+    case tag of+      Leaf _ -> pure projected+      Nested _ sub -> do+        subDistribute <- nested sub+        pure $ appE (varE subDistribute) projected+  let body = foldl' appE (conE collectionName) fields+  clause [varP arg] (normalB body) []+ -- * Representable -{- |-@-index c = \case This -> this c; That -> that c; …-@+{- $representable++<https://hackage-content.haskell.org/package/adjunctions-4.4.4/docs/Data-Functor-Rep.html>++The instance generators need the @adjunctions@ package as a dependency of the splicing package,+not of @recollections@.+The class is looked up in the splicing module scope, so it has to be imported there.+The splicing module also needs @TypeFamilies@ for the @Rep@ instance. -}++{- | Generate a Representable instance.++The splicing module must import "Data.Functor.Rep", unqualified or qualified without an alias.+Use 'mkRepresentableFor' when the module is imported under an alias.++Representable requires a Distributive instance, see 'mkDistributive'.++> instance Representable Collection where+>   type Rep Collection = Things+>   index c = \case This -> this c; That -> that c+>   tabulate k = Collection { this = k This, that = k That }+-}+mkRepresentable :: Name -> Q [Dec]+mkRepresentable tags = do+  representable <- lookupClass "Data.Functor.Rep" "Representable"+  mkRepresentableFor representable tags++{- | Generate a Representable instance for the explicitly provided class name.++> import qualified Data.Functor.Rep as R+>+> mkRepresentableFor ''R.Representable ''Things+-}+mkRepresentableFor :: Name -> Name -> Q [Dec]+mkRepresentableFor representable tags = do+  names <- tagNames tags+  repName <- classMember mkNameG_tc representable "Rep"+  indexName <- classMember mkNameG_v representable "index"+  tabulateName <- classMember mkNameG_v representable "tabulate"+  pure <$> instanceD (cxt []) (conT representable `appT` conT collectionName)+    [ tySynInstD $ tySynEqn Nothing (conT repName `appT` conT collectionName) (conT tags)+    , funD indexName [indexClause (const $ pure indexName) names]+    , inlineP indexName+    , funD tabulateName [tabulateClause (const $ pure tabulateName) names]+    , inlineP tabulateName+    ]++{- | Read a collection field using an index value.++Doesn't need the @adjunctions@ package, but clashes with the "Data.Functor.Rep" import.++> index :: Collection a -> Things -> a+> index c = \case This -> this c; That -> that c; …+-} mkIndex :: Name -> Q [Dec] mkIndex tags = do-  let collectionName = mkName "Collection"   let indexName = mkName "index"   names <- tagNames tags   let a = mkName "a"   sig <- sigD indexName $     appT (appT arrowT (conT collectionName `appT` varT a)) $       appT (appT arrowT (conT tags)) (varT a)-  bounds <- for names \name ->-    (,) name <$> newName (fieldNameOf name)-  let-    body = lamCaseE do-      (name, bound) <- bounds-      pure $ match (conP (mkName name) []) (normalB $ varE bound) []+  fun <- funD indexName [indexClause (siblingOf mkNameG_v "index") names]+  inl <- inlineP indexName+  pure [sig, fun, inl] -  fun <- funD indexName-    [ clause-        [ conP collectionName $ map (varP . snd) bounds-        ]-        (normalB body)+indexClause :: (Name -> Q Name) -> [Tag] -> Q Clause+indexClause nested names = do+  bounds <- for names \tag ->+    (,) tag <$> newName (fieldNameOf $ tagName tag)+  matches <- for bounds \case+    (Leaf name, bound) ->+      pure $ match (conP (mkName name) []) (normalB $ varE bound) []+    (Nested name sub, bound) -> do+      subIndex <- nested sub+      subTag <- newName "t"+      pure $ match+        (conP (mkName name) [varP subTag])+        (normalB $ varE subIndex `appE` varE bound `appE` varE subTag)         []+  let body = lamCaseE matches+  clause+    [ conP collectionName $ map (varP . snd) bounds     ]-  inl <- inlineP indexName-  pure [sig, fun, inl]+    (normalB body)+    [] -{- |-@-tabulate k = Collection (k This) (k That) (k Something) (k Else) (k Entirely)-@+{- | Generate a collection with a function from its indices++Doesn't need the @adjunctions@ package, but clashes with the "Data.Functor.Rep" import.++> tabulate :: (Things -> a) -> Collection a+> tabulate k = Collection { this = k This, that = k That } -} mkTabulate :: Name -> Q [Dec] mkTabulate tags = do-  let collectionName = mkName "Collection"   let tabulateName = mkName "tabulate"   names <- tagNames tags   let a = mkName "a"   sig <- sigD tabulateName $     appT (appT arrowT (appT (appT arrowT (conT tags)) (varT a))) $       conT collectionName `appT` varT a+  fun <- funD tabulateName [tabulateClause (siblingOf mkNameG_v "tabulate") names]+  inl <- inlineP tabulateName+  pure [sig, fun, inl]++tabulateClause :: (Name -> Q Name) -> [Tag] -> Q Clause+tabulateClause nested names = do   f <- newName "_f"+  fields <- for names \case+    Leaf name -> pure $ appE (varE f) $ conE (mkName name)+    Nested name sub -> do+      subTabulate <- nested sub+      pure $ appE (varE subTabulate) $ infixE (Just $ varE f) (varE '(.)) (Just . conE $ mkName name)+  let body = foldl' appE (conE collectionName) fields+  clause [varP f] (normalB body) []++-- * Tag instances++{- $tagInstances++Stock 'Bounded' and 'Enum' only work for nullary constructors.+These generators also handle nested tags, using the 'Bounded' and 'Enum' instances of the nested tag types.+Those may be derived or generated.+-}++{- | Generate a 'Bounded' instance for the tag type.++> data Tag = Front Inner.Tag | Local | Back Inner.Tag+>+> instance Bounded Tag where+>   minBound = Front minBound+>   maxBound = Back maxBound+-}+mkBounded :: Name -> Q [Dec]+mkBounded tags = do+  names <- tagNames tags+  (first, final) <- case (names, reverse names) of+    (first : _, final : _) -> pure (first, final)+    _ -> fail $ "Can't bound a type without constructors: " <> show tags   let-    body =-      foldl' appE (conE collectionName) do-        name <- names-        pure $ appE (varE f) $ conE (mkName name)-  fun <- funD tabulateName-    [ clause [varP f] (normalB body) []+    bound method = \case+      Leaf name -> conE $ mkName name+      Nested name _ -> conE (mkName name) `appE` varE method+  pure <$> instanceD (cxt []) (conT ''Bounded `appT` conT tags)+    [ valD (varP 'minBound) (normalB $ bound 'minBound first) []+    , valD (varP 'maxBound) (normalB $ bound 'maxBound final) []     ]-  inl <- inlineP tabulateName-  pure [sig, fun, inl] +{- | Generate an 'Enum' instance for the tag type, numbering the nested tags in place.++> data Tag = Front Inner.Tag | Local | Back Inner.Tag+>+> instance Enum Tag where+>   fromEnum t = case t of+>     Front x -> o0 + (fromEnum x - lo)+>     Local -> o1+>     Back x -> o2 + (fromEnum x - lo)+>     where+>       o0 = 0+>       o1 = o0 + (hi - lo + 1)+>       o2 = o1 + 1+>   toEnum n+>     | n < 0 = errorWithoutStackTrace …+>     | n < o1 = Front (toEnum (n - o0 + lo))+>     | n < o2 = Local+>     | n < o3 = Back (toEnum (n - o2 + lo))+>     | otherwise = errorWithoutStackTrace …+>     where+>       …+>       o3 = o2 + (hi - lo + 1)+>   enumFrom = boundedEnumFrom+>   enumFromThen = boundedEnumFromThen++Here @lo@ and @hi@ stand for the inlined @fromEnum (minBound :: Inner.Tag)@ and @fromEnum (maxBound :: Inner.Tag)@.++The instance requires @Bounded Tag@, see 'mkBounded'.+-}+mkEnum :: Name -> Q [Dec]+mkEnum tags = do+  names <- tagNames tags+  fromEnumClause <- do+    (offsets, bindings) <- runningOffsets . reverse . drop 1 $ reverse names+    t <- newName "t"+    matches <- fromEnumMatches $ zip names offsets+    pure $ clause [varP t] (normalB $ caseE (varE t) matches) bindings+  toEnumClause <- do+    (offsets, bindings) <- runningOffsets names+    n <- newName "n"+    pure $ clause [varP n] (toEnumBody tags n $ zip3 names offsets (drop 1 offsets)) bindings+  pure <$> instanceD (cxt []) (conT ''Enum `appT` conT tags)+    [ funD 'fromEnum [fromEnumClause]+    , funD 'toEnum [toEnumClause]+    , valD (varP 'enumFrom) (normalB $ varE 'boundedEnumFrom) []+    , valD (varP 'enumFromThen) (normalB $ varE 'boundedEnumFromThen) []+    ]++fromEnumMatches :: [(Tag, Name)] -> Q [Q Match]+fromEnumMatches spans =+  for spans \case+    (Leaf name, before) ->+      pure $ match (conP (mkName name) []) (normalB $ varE before) []+    (Nested name sub, before) -> do+      subTag <- newName "t"+      pure $ match+        (conP (mkName name) [varP subTag])+        (normalB $ plusE (varE before) (minusE (varE 'fromEnum `appE` varE subTag) (fromEnumOf 'minBound sub)))+        []++toEnumBody :: Name -> Name -> [(Tag, Name, Name)] -> Q Body+toEnumBody tags n spans =+  guardedB $+    [normalGE (lessThan . litE $ integerL 0) outOfRange]+    <> map pick spans+    <> [normalGE (varE 'otherwise) outOfRange]+  where+    lessThan bound = infixE (Just $ varE n) (varE '(<)) (Just bound)+    pick = \case+      (Leaf name, _, after) ->+        normalGE (lessThan $ varE after) (conE $ mkName name)+      (Nested name sub, before, after) ->+        normalGE (lessThan $ varE after) $+          conE (mkName name) `appE`+            (varE 'toEnum `appE` plusE (minusE (varE n) (varE before)) (fromEnumOf 'minBound sub))+    outOfRange =+      varE 'errorWithoutStackTrace `appE`+        infixE+          (Just . stringE $ "toEnum{" <> nameBase tags <> "}: out of range: ")+          (varE '(<>))+          (Just $ varE 'show `appE` varE n)++runningOffsets :: [Tag] -> Q ([Name], [Q Dec])+runningOffsets names = do+  first <- newName "o0"+  rest <- for [1 .. length names] \i -> newName $ "o" <> show i+  let offsets = first : rest+  let+    sizeE = \case+      Leaf _ -> litE $ integerL 1+      Nested _ sub -> plusE (minusE (fromEnumOf 'maxBound sub) (fromEnumOf 'minBound sub)) (litE $ integerL 1)+    start = valD (varP first) (normalB . litE $ integerL 0) []+    steps = do+      (before, after, tag) <- zip3 offsets (drop 1 offsets) names+      pure $ valD (varP after) (normalB $ plusE (varE before) (sizeE tag)) []+  pure (offsets, start : steps)++fromEnumOf :: Name -> Name -> Q Exp+fromEnumOf bound sub = varE 'fromEnum `appE` sigE (varE bound) (conT sub)++plusE :: Q Exp -> Q Exp -> Q Exp+plusE a b = infixE (Just a) (varE '(+)) (Just b)++minusE :: Q Exp -> Q Exp -> Q Exp+minusE a b = infixE (Just a) (varE '(-)) (Just b)+ -- * Utils -tagNames :: Name -> Q [String]+collectionName :: Name+collectionName = mkName "Collection"++lookupClass :: String -> String -> Q Name+lookupClass moduleName className = do+  found <- traverse lookupTypeName [moduleName <> "." <> className, className]+  case asum found of+    Just name ->+      pure name+    Nothing ->+      fail $ concat+        [ className, " is not in scope. Import ", moduleName+        , " or use mk", className, "For with an explicit class name."+        ]++classMember :: (String -> String -> String -> Name) -> Name -> String -> Q Name+classMember mkMember className member =+  case (namePackage className, nameModule className) of+    (Just package, Just moduleName) ->+      pure $ mkMember package moduleName member+    _ ->+      fail $ "Expected an imported class name, got: " <> show className++data Tag+  = Leaf String+  | Nested String Name++tagName :: Tag -> String+tagName = \case+  Leaf name -> name+  Nested name _ -> name++tagNames :: Name -> Q [Tag] tagNames tags =  reify tags >>= \case     TyConI (DataD _ _ _ _ constructors _) ->-      foldrM (flip extractTags) [] constructors+      foldrM (flip $ extractTags tags) [] constructors     _ ->       fail "Expected a type constructor name" -extractTags :: [String] -> Con -> Q [String]-extractTags acc = \case+extractTags :: Name -> [Tag] -> Con -> Q [Tag]+extractTags tags acc = \case   NormalC name [] ->-    pure $ nameBase name : acc+    pure $ Leaf (nameBase name) : acc+  NormalC name [(_, ConT sub)]+    | sub == tags ->+        fail $ "A tag can't nest its own type: " <> show name+    | otherwise ->+        pure $ Nested (nameBase name) sub : acc   huh ->     -- Skipping would produce a 'Collection' with fewer fields than there are     -- tags, making the generated 'index' silently non-exhaustive.-    fail $ "Expected a nullary constructor, got: " <> show huh+    fail $ "Expected a nullary constructor or one wrapping a nested tag type, got: " <> show huh++siblingOf :: (String -> String -> String -> Name) -> String -> Name -> Q Name+siblingOf mkNameG occ sub =+  case (namePackage sub, nameModule sub) of+    (Just pkg, Just modName) -> do+      let sibling = mkNameG pkg modName occ+      recover+        (fail $ "Nested tag " <> show sub <> " needs " <> occ <> " generated in " <> modName)+        (sibling <$ reify sibling)+    _ ->+      fail $ "Nested tag " <> show sub <> " must be a top-level type from another module"  -- | Lowercase the leading character and dodge reserved words. fieldNameOf :: String -> String

@@ -0,0 +1,30 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -ddump-splices #-}++module Aliased (checks) where++import Data.Recollections.TH+import GHC.Generics (Generically1(..))++import qualified Data.Distributive as D+import qualified Data.Functor.Rep as R++data Sides+  = North+  | South+  | East+  | West+  deriving (Eq, Ord, Show, Enum, Bounded)++mkCollection ''Sides+mkIndices ''Sides+mkDistributiveFor ''D.Distributive ''Sides+mkRepresentableFor ''R.Representable ''Sides++checks :: [(String, Bool)]+checks =+  [ ("aliased index . indices", all (\s -> R.index indices s == s) [minBound .. maxBound])+  , ("aliased tabulate id", R.tabulate id == indices)+  , ("aliased distribute", D.distribute (Just indices) == fmap Just indices)+  ]

@@ -0,0 +1,52 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -ddump-splices #-}++module Main (main) where++import Control.Monad (unless)+import Data.Foldable (traverse_)+import Data.Distributive+import Data.Functor.Rep+import Data.Recollections.TH+import GHC.Generics+import System.Exit (exitFailure)++import qualified Aliased+import qualified Nested.Outer++data Things+  = This+  | That+  | Something+  | Else+  | Entirely+  deriving (Eq, Ord, Show, Enum, Bounded, Generic)++mkCollection ''Things+mkIndices ''Things+mkDistributive ''Things+mkRepresentable ''Things++positions :: Collection (Data.Functor.Rep.Rep Collection)+positions = tabulate id++main :: IO ()+main = do+  putStrLn $ "Representable.tabulate show: " <> show (tabulate @Collection show)+  putStrLn ""+  putStrLn $ "Distributive.distribute: " <> show (distribute [indices])+  putStrLn ""+  putStrLn $ "imapRep: " <> show (imapRep (,) (fmap fromEnum indices))+  putStrLn ""+  traverse_ check $+    [ ("index . indices", all (\t -> index indices t == t) [minBound .. maxBound])+    , ("tabulate id", positions == indices)+    , ("distribute", distribute [indices] == fmap pure indices)+    , ("mzipWithRep", mzipWithRep (+) (fmap fromEnum indices) (pure 1) == fmap (succ . fromEnum) indices)+    , ("fmapRep", fmapRep fromEnum indices == fmap fromEnum indices)+    ] <> Aliased.checks <> Nested.Outer.checks+  where+    check (label, ok) = do+      putStrLn $ label <> ": " <> show ok+      unless ok exitFailure

@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Nested.Inner+  ( Tag(..)+  , Collection(..)+  , indices+  ) where++import Data.Distributive (Distributive(..))+import Data.Functor.Rep (Representable(..))+import Data.Recollections.TH+import GHC.Generics++data Tag = Foo | Bar | Baz+  deriving (Eq, Ord, Show)++mkCollection ''Tag+mkIndices ''Tag+mkDistributive ''Tag+mkRepresentable ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Nested.Outer (checks) where++import Data.Distributive (Distributive(..))+import Data.Foldable (toList)+import Data.Functor.Rep (Representable(..))+import Data.Recollections.TH+import GHC.Generics+import Nested.Inner qualified as Inner++data Tag+  = Front Inner.Tag+  | Local+  | Back Inner.Tag+  deriving (Eq, Ord, Show)++mkCollection ''Tag+mkIndices ''Tag+mkDistributive ''Tag+mkRepresentable ''Tag+mkBounded ''Tag+mkEnum ''Tag++checks :: [(String, Bool)]+checks =+  [ ("nested index . indices", all (\t -> index indices t == t) [minBound .. maxBound])+  , ("nested tabulate id", tabulate id == indices)+  , ("nested distribute", distribute (Just indices) == fmap Just indices)+  , ("nested enum order", toList indices == [minBound .. maxBound])+  ]

@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}++module Nested.Inner+  ( Tag(..)+  , Collection(..)+  , indices+  , distribute+  , index+  , tabulate+  ) where++import Data.Recollections.TH+import GHC.Generics++data Tag = Foo | Bar | Baz+  deriving (Eq, Ord, Show)++mkCollection ''Tag+mkIndices ''Tag+mkDistribute ''Tag+mkIndex ''Tag+mkTabulate ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -0,0 +1,28 @@+{-# LANGUAGE TemplateHaskell #-}++module Nested.Outer+  ( Tag(..)+  , Collection(..)+  , indices+  , distribute+  , index+  , tabulate+  ) where++import Data.Recollections.TH+import GHC.Generics+import Nested.Inner qualified as Inner++data Tag+  = Front Inner.Tag+  | Local+  | Back Inner.Tag+  deriving (Eq, Ord, Show)++mkCollection ''Tag+mkIndices ''Tag+mkDistribute ''Tag+mkIndex ''Tag+mkTabulate ''Tag+mkBounded ''Tag+mkEnum ''Tag

@@ -4,7 +4,10 @@ module Main (main) where  import Data.Recollections.TH+import Data.Foldable (toList) import GHC.Generics+import Nested.Inner qualified as Inner+import Nested.Outer qualified as Outer  data Things   = This@@ -20,12 +23,6 @@ mkIndex ''Things mkTabulate ''Things --- data Collection a = Collection---   { this, that, something, else', entirely :: a---   }---   deriving stock (Eq, Show, Generic1, Functor, Foldable, Traversable)---   deriving Applicative via (Generically1 Collection)- main :: IO () main = do   putStrLn $ "Applicative: " <>  show (pure @Collection ())@@ -41,3 +38,23 @@   putStrLn $ "Ditributive.distribute: " <>  show (distribute [indices])   putStrLn ""   putStrLn $ "Ditributive.collect: " <>  show (distribute . fmap (\thing -> pure $ thing == This) $ indices)+  putStrLn ""+  putStrLn $ "Nested indices: " <> show Outer.indices+  putStrLn ""+  putStrLn $ "Nested index roundtrip: " <> show (all (\t -> Outer.index Outer.indices t == t) Outer.indices)+  putStrLn ""+  putStrLn $ "Nested tabulate show: " <> show (Outer.tabulate show)+  putStrLn ""+  putStrLn $ "Nested distribute: " <> show (Outer.distribute [Outer.indices, Outer.indices])+  putStrLn ""+  putStrLn $ "Nested applicative: " <> show ((,) <$> Outer.indices <*> pure ())+  putStrLn ""+  putStrLn $ "Nested bounds: " <> show (minBound @Outer.Tag, maxBound @Outer.Tag)+  putStrLn ""+  putStrLn $ "Nested enum matches indices: " <> show ([minBound .. maxBound] == toList Outer.indices)+  putStrLn ""+  putStrLn $ "Nested fromEnum: " <> show (fmap fromEnum Outer.indices)+  putStrLn ""+  putStrLn $ "Nested toEnum roundtrip: " <> show (all (\t -> toEnum (fromEnum t) == t) Outer.indices)+  putStrLn ""+  putStrLn $ "Nested enumFromThen: " <> show [Outer.Front Inner.Bar, Outer.Local ..]