Merge pull request #4476 from JacquesCarette/derivingHasChunkRefs

`declareHasChunkRefs`: Generate instances of `HasChunkRefs` where possible

Author: JacquesCarette

code/drasil-database/lib/Drasil/Database.hs

@@ -4,11 +4,13 @@ module Drasil.Database (
   module Drasil.Database.ChunkDB,
   module Drasil.Database.Dump,
   module Drasil.Database.UID,
+  module Drasil.Database.TH,
   module Drasil.Database.TypedUIDRef
 ) where
 
 import Drasil.Database.Chunk
 import Drasil.Database.ChunkDB
 import Drasil.Database.Dump
+import Drasil.Database.TH
 import Drasil.Database.TypedUIDRef
 import Drasil.Database.UID

code/drasil-database/lib/Drasil/Database/Chunk.hs

@@ -1,29 +1,28 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE InstanceSigs #-}
-
-module Drasil.Database.Chunk
-  ( Chunk,
-    IsChunk,
-    HasChunkRefs (..),
-    mkChunk, -- FIXME: mkChunk should not be exported but is temporarily because this module is NOT in `drasil-database`
-    unChunk,
-    chunkType,
-  )
-where
+{-# LANGUAGE ExistentialQuantification,
+             ConstraintKinds,
+             InstanceSigs,
+             TypeOperators,
+             TypeApplications,
+             FlexibleContexts,
+             UndecidableInstances,
+             FlexibleInstances #-}
+module Drasil.Database.Chunk (
+  Chunk,
+  IsChunk,
+  HasChunkRefs(..),
+  mkChunk, -- FIXME: mkChunk should not be exported but is temporarily because this module is NOT in `drasil-database`
+  unChunk,
+  chunkType
+) where
 
 import Control.Lens ((^.), to, Getter)
-import Data.Typeable (Proxy (Proxy), TypeRep, Typeable, cast, typeOf, typeRep)
 import qualified Data.Set as S
+import Data.Typeable (Proxy (Proxy), TypeRep, Typeable, cast, typeOf, typeRep)
+import GHC.Generics (Generic (Rep, from), M1 (..), K1 (..), type (:*:) (..),
+  type (:+:) (..), U1, Generically(..))
 
 import Drasil.Database.UID (HasUID (..), UID)
 
--- | All chunks should expose what chunks they reference/rely on, so that we can
--- test 'ChunkDB's to ensure all presupposed chunks are already registered.
-class HasChunkRefs a where
-  chunkRefs :: a -> S.Set UID
-
 -- | Constraint for anything that may be considered a valid chunk type.
 type IsChunk a = (HasUID a, HasChunkRefs a, Typeable a)
 
@@ -56,3 +55,91 @@ unChunk (Chunk c) = cast c
 -- | Ask a 'Chunk' for the type of data it codifies.
 chunkType :: Chunk -> TypeRep
 chunkType (Chunk c) = typeOf c
+
+-- | The majority of chunks will relate other chunks in some way. In other
+-- words, the majority of our chunks *depend* on others. 'HasChunkRefs' is meant
+-- as a way to capture what things a chunk *directly* refers to (i.e., depends
+-- on directly).
+class HasChunkRefs a where
+  chunkRefs :: a -> S.Set UID
+
+instance HasChunkRefs UID where
+  -- | 'UID's are meant to be "owned" (i.e., they are the unique identifier of
+  -- the chunk being defined), not *carried as references to other chunks*.
+  -- 'TypedUIDRef t' exists to be used as a *reference to another chunk of type
+  -- 't'*. Therefore, `UID` has no chunk references.
+  chunkRefs _ = S.empty
+  {-# INLINABLE chunkRefs #-}
+
+instance HasChunkRefs Int where
+  chunkRefs _ = S.empty
+  {-# INLINABLE chunkRefs #-}
+
+instance HasChunkRefs Integer where
+  chunkRefs _ = S.empty
+  {-# INLINABLE chunkRefs #-}
+
+instance HasChunkRefs Double where
+  chunkRefs _ = S.empty
+  {-# INLINABLE chunkRefs #-}
+
+instance HasChunkRefs Bool where
+  chunkRefs _ = S.empty
+  {-# INLINABLE chunkRefs #-}
+
+instance HasChunkRefs Char where
+  chunkRefs _ = S.empty
+  {-# INLINABLE chunkRefs #-}
+
+-- NOTE: 'OVERLAPPING' instance here because [Char] is instantiated with
+-- `HasChunkRefs [a]`, but very inefficient. We already know the result will be
+-- empty.
+instance {-# OVERLAPPING #-} HasChunkRefs String where
+  chunkRefs _ = S.empty
+  {-# INLINABLE chunkRefs #-}
+
+instance HasChunkRefs a => HasChunkRefs [a] where
+  chunkRefs = S.unions . map chunkRefs
+  {-# INLINABLE chunkRefs #-}
+
+instance HasChunkRefs a => HasChunkRefs (Maybe a) where
+  chunkRefs Nothing = S.empty
+  chunkRefs (Just v) = chunkRefs v
+  {-# INLINABLE chunkRefs #-}
+
+instance (HasChunkRefs l, HasChunkRefs r) => HasChunkRefs (Either l r) where
+  chunkRefs = either chunkRefs chunkRefs
+  {-# INLINABLE chunkRefs #-}
+
+instance (Generic a, GHasCRefs (Rep a)) => HasChunkRefs (Generically a) where
+  chunkRefs (Generically a) = gChunkRefs $ from a
+  {-# INLINABLE chunkRefs #-}
+
+class GHasCRefs f where
+  gChunkRefs :: f p -> S.Set UID
+
+-- Meta-information (constructors, selectors): pass through
+instance GHasCRefs f => GHasCRefs (M1 i c f) where
+  gChunkRefs (M1 x) = gChunkRefs x
+  {-# INLINABLE gChunkRefs #-}
+
+-- Products: Union
+instance (GHasCRefs a, GHasCRefs b) => GHasCRefs (a :*: b) where
+  gChunkRefs (a :*: b) = gChunkRefs a `S.union` gChunkRefs b
+  {-# INLINABLE gChunkRefs #-}
+
+-- Sums: Depends on variant
+instance (GHasCRefs a, GHasCRefs b) => GHasCRefs (a :+: b) where
+  gChunkRefs (L1 x) = gChunkRefs x
+  gChunkRefs (R1 x) = gChunkRefs x
+  {-# INLINABLE gChunkRefs #-}
+
+-- Fields: Delegate
+instance HasChunkRefs c => GHasCRefs (K1 i c) where
+  gChunkRefs (K1 x) = chunkRefs x
+  {-# INLINABLE gChunkRefs #-}
+
+-- Unit: Nothing!
+instance GHasCRefs U1 where
+  gChunkRefs _ = S.empty
+  {-# INLINABLE gChunkRefs #-}

code/drasil-database/lib/Drasil/Database/README.md

@@ -6,4 +6,5 @@ _Last updated: Dec. 4th, 2025_
 * `ChunkDB.hs`: Want to aggregate all your chunks? Use this database.
 * `Dump.hs`: Simple tool for dumping all known chunks in a database (grouped by type).
 * `UID.hs`: Defines the structure of universally unique identifiers we use for our chunk database.
+* `TH.hs`: Defines an automation tool for declaring that a 'chunk type' has 'chunk references'.
 * `TypedUIDRef.hs`: `UID`s are great! But _untyped._ Creates a chunk reference data type that carries type information at the Haskell-type-level for type-safe `UID` references!

code/drasil-database/lib/Drasil/Database/TH.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module Drasil.Database.TH (
+  -- * The Magic
+  declareHasChunkRefs,
+  -- * Re-exports from GHC.Generics for convenience
+  Generic,
+  Generically(..)
+) where
+
+import GHC.Generics (Generic, Generically(..))
+import Language.Haskell.TH (Name, Q, Dec(..), Type(..), DerivStrategy(..))
+
+import Drasil.Database.Chunk (HasChunkRefs)
+
+-- | Declares that a type is a chunk type; Generates an instance of
+-- 'HasChunkRefs'.
+declareHasChunkRefs :: Name -> Q [Dec]
+declareHasChunkRefs = deriveGenerically [''HasChunkRefs]
+
+-- | Generates:
+--
+-- 1. A 'Generic' instance for the type:
+-- @
+--   deriving stock instance Generic Ty
+-- @
+--
+-- 2. For all type classes to be derived generically:
+-- @
+--   deriving via Generically Ty instance TheClass Ty
+-- @
+deriveGenerically :: [Name] -> Name -> Q [Dec]
+deriveGenerically clss ty = do
+  let typeCon = ConT ty
+
+      -- deriving stock instance Generic Ty
+      drvGeneric = StandaloneDerivD
+        (Just StockStrategy)
+        []
+        (AppT (ConT ''Generic) typeCon)
+
+      -- deriving via Generically Ty instance TheClass Ty
+      drvCls cls = StandaloneDerivD
+        (Just (ViaStrategy (AppT (ConT ''Generically) typeCon)))
+        []
+        (AppT (ConT cls) typeCon)
+
+      -- Gather all classes we want to derive generically
+      clsDrvs = map drvCls clss
+
+  return $ drvGeneric : clsDrvs

code/drasil-database/lib/Drasil/Database/TypedUIDRef.hs

@@ -6,14 +6,20 @@ module Drasil.Database.TypedUIDRef (
 import Control.Lens ((^.))
 import Data.Maybe (fromMaybe)
 
-import Drasil.Database.Chunk (IsChunk)
+import Drasil.Database.Chunk (IsChunk, HasChunkRefs (..))
 import Drasil.Database.ChunkDB (ChunkDB, find)
 import Drasil.Database.UID (HasUID(..), UID)
+import qualified Data.Set as S (singleton)
 
 -- | 'UID' references that contain information about the type of data the 'UID'
 -- refers to, useful for type-safe dereferencing.
 newtype TypedUIDRef typ = TypedUIDRef UID
 
+instance HasChunkRefs (TypedUIDRef t) where
+  -- | A 'TypedUIDRef t' carries a 'UID' referring to a chunk of type 't'.
+  chunkRefs (TypedUIDRef u) = S.singleton u
+  {-# INLINABLE chunkRefs #-}
+
 -- | Create a 'TypedUIDRef' to a chunk.
 mkRef :: IsChunk t => t -> TypedUIDRef t
 mkRef t = TypedUIDRef $ t ^. uid

code/drasil-database/lib/Drasil/Database/UID.hs

@@ -18,9 +18,9 @@ import GHC.Generics
 
 import Control.Lens (Getter, makeLenses, (^.), view, over)
 
--- | The most basic item: having a unique identifier key, here a UID.
+-- | The most basic item: having a unique identifier key, a 'UID'.
 class HasUID c where
-  -- | Provides a /unique/ id for internal Drasil use.
+  -- | The /unique/ id of the chunk (for internal Drasil use only).
   uid :: Getter c UID
 
 -- | A @UID@ is a 'unique identifier' for things that we will put into our

code/drasil-database/package.yaml

@@ -18,6 +18,7 @@ dependencies:
 - aeson
 - containers
 - lens
+- template-haskell
 - text
 - drasil-utils
 

code/drasil-lang/lib/Language/Drasil/Chunk/NamedIdea.hs

@@ -9,10 +9,9 @@ module Language.Drasil.Chunk.NamedIdea (
   nc, ncUID, nw, mkIdea, mkIdeaUID
 ) where
 
-import Control.Lens ((^.), makeLenses)
-import Control.Lens.Lens (Lens')
+import Control.Lens ((^.), makeLenses, Lens')
 
-import Drasil.Database (HasChunkRefs(..), mkUid, UID, HasUID(..))
+import Drasil.Database (mkUid, UID, HasUID(..), declareHasChunkRefs, Generically(..))
 import Language.Drasil.NounPhrase.Core (NP)
 
 -- TODO: Why does a NamedIdea need a UID? It might need a UID to be registered in the chunk map.
@@ -53,11 +52,9 @@ data IdeaDict = IdeaDict {
   _np :: NP,
   mabbr :: Maybe String
 }
+declareHasChunkRefs ''IdeaDict
 makeLenses ''IdeaDict
 
-instance HasChunkRefs IdeaDict where
-  chunkRefs = const mempty -- FIXME: `chunkRefs` should actually collect the referenced chunks.
-
 -- | Equal if 'UID's are equal.
 instance Eq        IdeaDict where a == b = a ^. uid == b ^. uid
 -- | Finds the 'UID' of the 'IdeaDict' used to make the 'IdeaDict'.

code/drasil-lang/lib/Language/Drasil/NounPhrase/Core.hs

@@ -3,7 +3,10 @@ module Language.Drasil.NounPhrase.Core (
   -- * Types
   CapitalizationRule(..), NP(..),
   PluralForm, PluralRule(..),
-  NPStruct(S,(:-:),(:+:),P)) where
+  NPStruct(S,(:-:),(:+:),P)
+) where
+
+import Drasil.Database (HasChunkRefs(..))
 
 import Language.Drasil.Symbol (Symbol)
 
@@ -47,3 +50,6 @@ data NP =
   --capitalization, one of the two cannot be capitalized right now.
   --The two capitalization rules are for sentenceCase / titleCase respectively
 
+instance HasChunkRefs NP where
+    chunkRefs _ = mempty
+    {-# INLINABLE chunkRefs #-}

code/drasil-lang/package.yaml

@@ -10,6 +10,9 @@ description: Please see the README on GitHub at <https://github.com/JacquesCaret
 language: Haskell2010
 default-extensions:
 - StrictData
+- StandaloneDeriving
+- DerivingVia
+- DeriveGeneric
 
 extra-source-files: []