recollections (empty) → 0.1.0.0

raw patch · 6 files changed

+424/−0 lines, 6 filesdep +basedep +recollectionsdep +template-haskell

Dependencies added: base, recollections, template-haskell

Files

CHANGELOG.md +11/−0
LICENSE +26/−0
README.md +65/−0
recollections.cabal +68/−0
src/Data/Recollections/TH.hs +211/−0
test/Spec.hs +43/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog for `recollections`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## 0.1.0.0 - 2026-07-26++Initial release.

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright 2026 IC Rainbow++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  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.++3.  Neither the name of the copyright holder 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.

+ README.md view

@@ -0,0 +1,65 @@+# recollections++The splicing module needs these extensions and imports:++```haskell+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}++import GHC.Generics (Generically1(..))+```++Given an enumeration of things like++```haskell+data Things+  = This+  | That+  | Something+  | Else+  | Entirely+  deriving (Eq, Ord, Show, Enum, Bounded, Generic)+```++We can derive a record that will behave like a homogenous zip-list of static size:++```haskell+mkCollection ''Things++-- data Collection a = Collection+--   { this, that, something, else', entirely :: a+--   }+--   deriving stock (Eq, Show, Generic1, Functor, Foldable, Traversable)+--   deriving Applicative via (Generically1 Collection)++-- Fill the record with its indices+mkIndices ''Things+```++## Kmettoverse-lite++```haskell+-- Distributive+mkDistribute ''Things+-- collect is ++-- Representable+mkIndex ''Things+mkTabulate ''Things+```++## VS++- Vanilla monomorphic records: don't have functor/foldable/traversable/applicative goodies.+- Hand-rolling the functor: be my guest, hand-roll the field enum too, while you're at it.+- `Map Things a`: All fields are mandatory, all keys are known -> lookups are total and O(1). The optional fields are recoverable, with `Collection (Maybe a)`.+- `Things -> a`: The collection can be stored and loaded.++## 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.++The generated names (`Collection`, `indices`, `distribute`, `index`,+`tabulate`) are fixed, so a tag named e.g. `Index` will clash with them.

+ recollections.cabal view

@@ -0,0 +1,68 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.39.6.+--+-- see: https://github.com/sol/hpack++name:           recollections+version:        0.1.0.0+synopsis:       Fixed-size representable (Zippy Applicative) collections.+category:       Data Structures+author:         IC Rainbow+maintainer:     aenor.realm@gmail.com+copyright:      2026 IC Rainbow+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://gitlab.com/dpwiz/recollections++library+  exposed-modules:+      Data.Recollections.TH+  other-modules:+      Paths_recollections+  autogen-modules:+      Paths_recollections+  hs-source-dirs:+      src+  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+  build-depends:+      base >=4.18 && <5+    , template-haskell >=2.20+  default-language: GHC2021++test-suite recollections-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_recollections+  autogen-modules:+      Paths_recollections+  hs-source-dirs:+      test+  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:+      base >=4.18 && <5+    , recollections+    , template-haskell >=2.20+  default-language: GHC2021

+ src/Data/Recollections/TH.hs view

@@ -0,0 +1,211 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module Data.Recollections.TH+  ( mkCollection+  , mkIndices++  , mkDistribute++  , mkIndex+  , mkTabulate+  ) where++import Data.Char+import Data.Foldable+import Data.Traversable+import GHC.Generics (Generic, Generic1, Generically1)+import Language.Haskell.TH++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"))+  let constr = recC collectionName fields+  let+    derivs =+      [ derivClause (Just StockStrategy)+          [ conT ''Show+          , conT ''Eq+          , conT ''Generic+          , conT ''Generic1+          , conT ''Functor+          , conT ''Foldable+          , conT ''Traversable+          ]+      , derivClause (Just $ ViaStrategy $ ConT ''Generically1 `AppT` ConT collectionName)+        [ conT ''Applicative+        ]+      ]+  pure <$> dataD mempty collectionName [collectionTyVar] Nothing [constr] derivs++-- | The @a@ binder of @data Collection a@.+--+-- @template-haskell-2.21@ (GHC 9.8) changed the binder flag of 'dataD'+-- from @()@ to 'BndrVis'.+#if MIN_VERSION_template_haskell(2,21,0)+collectionTyVar :: TyVarBndrVis+collectionTyVar = PlainTV (mkName "a") BndrReq+#else+collectionTyVar :: TyVarBndrUnit+collectionTyVar = PlainTV (mkName "a") ()+#endif++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)+  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+  }+@+-}+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) []+    ]+  inl <- inlineP distributeName+  pure [sig, fun, inl]++-- * Representable++{- |+@+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+    [ clause+        [ conP collectionName $ map (varP . snd) bounds+        ]+        (normalB body)+        []+    ]+  inl <- inlineP indexName+  pure [sig, fun, inl]++{- |+@+tabulate k = Collection (k This) (k That) (k Something) (k Else) (k Entirely)+@+-}+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+  f <- newName "_f"+  let+    body =+      foldl' appE (conE collectionName) do+        name <- names+        pure $ appE (varE f) $ conE (mkName name)+  fun <- funD tabulateName+    [ clause [varP f] (normalB body) []+    ]+  inl <- inlineP tabulateName+  pure [sig, fun, inl]++-- * Utils++tagNames :: Name -> Q [String]+tagNames tags =+ reify tags >>= \case+    TyConI (DataD _ _ _ _ constructors _) ->+      foldrM (flip extractTags) [] constructors+    _ ->+      fail "Expected a type constructor name"++extractTags :: [String] -> Con -> Q [String]+extractTags acc = \case+  NormalC name [] ->+    pure $ nameBase name : 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++-- | Lowercase the leading character and dodge reserved words.+fieldNameOf :: String -> String+fieldNameOf = \case+  [] -> []+  n : ame -> legalizeVariableName $ toLower n : ame++legalizeVariableName :: String -> String+legalizeVariableName name+  | name `elem` illegal = name ++ "'"+  | otherwise = name++-- | Haskell 2010 reserved words, which cannot be used as record field names.+illegal :: [String]+illegal =+  [ "case", "class", "data", "default", "deriving", "do"+  , "else", "foreign", "if", "import", "in"+  , "infix", "infixl", "infixr", "instance"+  , "let", "module", "newtype", "of"+  , "then", "type", "where", "_"+  ]++inlineP :: Name -> Q Dec+inlineP name = pragInlD name Inline FunLike AllPhases

+ test/Spec.hs view

@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -ddump-splices #-}++module Main (main) where++import Data.Recollections.TH+import GHC.Generics++data Things+  = This+  | That+  | Something+  | Else+  | Entirely+  deriving (Eq, Ord, Show, Enum, Bounded, Generic)++mkCollection ''Things+mkIndices ''Things+mkDistribute ''Things+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 ())+  putStrLn ""+  putStrLn $ "indices: " <>  show indices+  putStrLn ""+  putStrLn $ "indices, numeric: " <>  show (fmap fromEnum indices)+  putStrLn ""+  putStrLn $ "Representable.index: " <>  show ([ (t, t == index indices t) | t <- [minBound .. maxBound] ])+  putStrLn ""+  putStrLn $ "Representable.tabulate show: " <>  show (tabulate show)+  putStrLn ""+  putStrLn $ "Ditributive.distribute: " <>  show (distribute [indices])+  putStrLn ""+  putStrLn $ "Ditributive.collect: " <>  show (distribute . fmap (\thing -> pure $ thing == This) $ indices)