Manifest.hs

-- | The build-wiring __manifest__: a Cabal-pasteable summary of what a
-- @scaffold@ run produced. @scaffold@ writes @.hs@ files but the consumer still
-- has to wire them into a Cabal stanza by hand — the @other-modules@ list and the
-- @build-depends@ implied by the node kinds. This module renders both as plain
-- text a human pastes into a @.cabal@ file (see @keiro-dsl/keiro-dsl.cabal@'s
-- conformance stanzas for the hand-maintained version this replaces).
--
-- The dependency set is a pure function of which 'Node' constructors occur in the
-- spec. The mapping is grounded in the existing per-suite @build-depends@ in
-- @keiro-dsl/keiro-dsl.cabal@:
--
--   * aggregate           => aeson, keiki, keiro, text, and time only when a direct
--                            aggregate surface uses Time   (keiro-dsl-conformance)
--   * process             => aeson, keiki, keiro, shibuya-core, text, time, uuid
--                                                          (…-process-runtime)
--   * contract            => aeson, text                   (…-contract)
--   * intake/emit/publisher (full integration path)
--                         => effectful-core, hasql-transaction, keiro, kiroku-store
--                                                          (…-intake-full)
--   * workqueue           => aeson, keiro-core, keiro-pgmq, text, plus containers/time
--                            when candidate payload expressions use Map/Time
--                                                          (…-queue, …-queue-runtime)
--   * dispatch            => aeson, effectful-core, keiro-pgmq, text
--                                                          (…-dispatch-full)
--   * workflow/operation  => containers, effectful-core, keiro, text
--                             (…-workflow-full; facts and runtime wiring only,
--                              with the body hand-owned)
--
-- @base@ is always present.
module Keiro.Dsl.Manifest
  ( renderManifest,
    renderManifestForService,
    renderManifestForServiceWithFacade,
    manifestDependencies,
    manifestDependenciesForService,
    moduleNameOf,
  )
where

import Data.List (nub, sort)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Keiro.Dsl.AggregateType
import Keiro.Dsl.GeneratedHaskellLanguage (generatedHaskellDefaultExtensions, generatedHaskellDefaultLanguage)
import Keiro.Dsl.Grammar
import Keiro.Dsl.IdDomain (contractIdDomainContractFor)
import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlanForService)
import Keiro.Dsl.NominalType
import Keiro.Dsl.Scaffold (ScaffoldModule (..))
import Keiro.Dsl.SemanticContract (CheckedService, checkedLanguageContract, checkedSpec, checkedTypeGraph, legacyCheckedService)

-- | Render a Cabal-pasteable manifest from the modules a scaffold run produced
-- plus the node kinds present (which imply the dependency set). The first argument
-- names the source spec (for the header comment).
renderManifest :: Text -> [ScaffoldModule] -> Spec -> Text
renderManifest specName mods = renderManifestForService specName mods . legacyCheckedService

-- | Service-aware manifest renderer. Semantic CLI and workspace routes use
-- this entry point so language-4 typed contract imports are represented in the
-- consuming Cabal dependencies.
renderManifestForService :: Text -> [ScaffoldModule] -> CheckedService -> Text
renderManifestForService = renderManifestForServiceWithFacade Nothing

-- | Configured manifest renderer. The service facade is the runtime library's
-- one generated public module; every other generated and hand-owned module
-- remains in @other-modules@. Passing 'Nothing' preserves the historical bytes.
renderManifestForServiceWithFacade :: Maybe Text -> Text -> [ScaffoldModule] -> CheckedService -> Text
renderManifestForServiceWithFacade facadeModule specName mods service =
  T.unlines $
    [ "-- keiro-dsl build manifest for " <> specName,
      "-- Paste the complete fragment below into the consuming Cabal stanza.",
      "-- The generated layer is overwritten on every scaffold; hole modules are",
      "-- create-if-absent (filled by hand).",
      "",
      "default-language: " <> generatedHaskellDefaultLanguage,
      "default-extensions:"
    ]
      ++ map ("    " <>) generatedHaskellDefaultExtensions
      ++ exposedBlock
      ++ [ "",
           "other-modules:"
         ]
      ++ map ("    " <>) otherModules
      ++ [ "",
           "build-depends:"
         ]
      ++ map ("    , " <>) (manifestDependenciesForService service)
      ++ consumerBlocks
  where
    plan = consumerPlanForService service
    moduleNames = sort (map (moduleNameOf . modulePath) mods)
    otherModules = case facadeModule of
      Nothing -> moduleNames
      Just facade -> filter (/= facade) moduleNames
    exposedBlock = case facadeModule of
      Nothing -> []
      Just facade -> ["", "exposed-modules:", "    " <> facade]
    consumerBlocks
      | null (consumerMappings plan) = []
      | otherwise =
          [ "",
            "consumer-packages:"
          ]
            ++ map ("    " <>) (consumerPackages plan)
            ++ [ "",
                 "consumer-modules:"
               ]
            ++ map ("    " <>) (consumerModules plan)

-- | The dotted module name recovered from a 'ScaffoldModule' path: drop the
-- trailing @.hs@ and replace @/@ with @.@.
moduleNameOf :: FilePath -> Text
moduleNameOf p = T.replace "/" "." (T.dropEnd 3 (T.pack p))

-- | The sorted, deduplicated dependency set implied by the node kinds present
-- in the spec. @base@ is always included.
manifestDependencies :: Spec -> [Text]
manifestDependencies = manifestDependenciesForService . legacyCheckedService

manifestDependenciesForService :: CheckedService -> [Text]
manifestDependenciesForService service =
  sort (nub ("base" : consumerPackages (consumerPlanForService service) <> concatMap (depsForNode service) (specNodes spec)))
  where
    spec = checkedSpec service

-- | The dependencies a single node kind implies (see the module header table).
depsForNode :: CheckedService -> Node -> [Text]
depsForNode service n = case n of
  NAggregate aggregate -> ["aeson", "keiki", "keiro", "text"] <> aggregateDependencies service aggregate
  NProcess {} -> ["aeson", "keiki", "keiro", "shibuya-core", "text", "time", "uuid"]
  NRouter {} -> ["effectful-core", "keiro", "shibuya-core", "text"]
  NContract contract -> ["aeson", "text"] <> [dependency | hasTypedContractId contract, dependency <- ["keiro-core", "mmzk-typeid"]]
  NIntake {} -> integration
  NEmit {} -> integration
  NPublisher {} -> integration
  NWorkqueue workqueue -> ["aeson", "keiro-core", "keiro-pgmq", "text"] <> workqueueDependencies workqueue
  NPgmqDispatch {} -> ["aeson", "effectful-core", "keiro-pgmq", "text"]
  NReadModel readModel -> ["effectful-core", "hasql-transaction", "keiro", "kiroku-store", "text"] <> readModelDependencies readModel
  NProjectionTarget {} -> ["keiro", "kiroku-store", "text"]
  NRebuildGroup {} -> ["keiro", "kiroku-store", "text"]
  NProjectionRevision {} -> ["containers", "hasql-transaction", "keiro", "kiroku-store", "text"]
  NExternalRead {} -> ["keiro"]
  NProjectionOwner {} -> ["keiro", "kiroku-store", "text"]
  NWorkflow {} -> ["containers", "effectful-core", "keiro", "text"]
  NOperation {} -> ["effectful-core", "keiro", "text"]
  where
    integration = ["effectful-core", "hasql-transaction", "keiro", "kiroku-store"]
    hasTypedContractId contract =
      or
        [ contractIdDomainContractFor (checkedLanguageContract service) prefix /= Nothing
        | event <- ctrEvents contract,
          field <- ceFields event,
          CTypeId prefix <- [cfType field]
        ]

workqueueDependencies :: WorkqueueNode -> [Text]
workqueueDependencies workqueue =
  ["containers" | any (typeExprUses isMap) expressions]
    <> ["time" | any (typeExprUses isTime) expressions]
  where
    expressions = [expression | field <- wqPayload workqueue, TypedQueueExpression expression <- [wqfType field]]
    isMap (TMap _) = True
    isMap _ = False
    isTime TTime = True
    isTime _ = False
    typeExprUses predicate expression =
      predicate expression
        || case expression of
          TOptional value -> typeExprUses predicate value
          TList value -> typeExprUses predicate value
          TMap value -> typeExprUses predicate value
          _ -> False

readModelDependencies :: ReadModelNode -> [Text]
readModelDependencies readModel =
  ["aeson" | any (typeExprUses isJson) expressions]
    <> ["containers" | any (typeExprUses isMap) expressions]
    <> ["time" | any (typeExprUses isTime) expressions]
  where
    expressions = case queryTypes readModel of
      Nothing -> []
      Just queryPair -> [input queryPair, result queryPair]
    isJson TJson = True
    isJson _ = False
    isMap TMap {} = True
    isMap _ = False
    isTime TTime = True
    isTime _ = False
    typeExprUses predicate expression =
      predicate expression
        || case expression of
          TOptional value -> typeExprUses predicate value
          TList value -> typeExprUses predicate value
          TMap value -> typeExprUses predicate value
          _ -> False

aggregateDependencies :: CheckedService -> Aggregate -> [Text]
aggregateDependencies service aggregate =
  Set.toAscList
    ( Set.unions
        [ aggregatePackages symbols resolvedType
        | resolvedType <- resolvedTypes
        ]
        <> Set.fromList
          [ "mmzk-typeid"
          | AggregateNominal nominal <- resolvedTypes,
            IdRepresentation {} <- [resolvedNominalRepresentation nominal],
            ConsumerNominal {} <- [resolvedNominalOwnership nominal]
          ]
    )
  where
    spec = checkedSpec service
    symbols = aggregateSymbolsFromGraphResult (checkedTypeGraph service) spec
    resolvedTypes =
      [ resolvedType
      | register <- aggRegs aggregate,
        Right resolvedType <- [resolveAggregateType symbols (regLoc register) RegisterUse (regType register)]
      ]
        <> [ resolvedType
           | command <- aggCommands aggregate,
             field <- cmdFields command,
             Right resolvedType <- [inferAggregateFieldType symbols aggregate CommandFieldUse field]
           ]
        <> [ resolvedType
           | event <- aggEvents aggregate,
             EventFields fields <- [evBody event],
             field <- fields,
             Right resolvedType <- [inferAggregateFieldType symbols aggregate EventFieldUse field]
           ]