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.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Keiro.Dsl.AggregateType
import Keiro.Dsl.ConsumerTypePlan (ConsumerTypePlan (..), ImportRequirement (..), planConsumerType)
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)
import Keiro.Dsl.TypeGraph

-- | 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 . (.path)) mods)
    otherModules = case facadeModule of
      Nothing -> moduleNames
      Just facade -> filter (/= facade) moduleNames
    exposedBlock = case facadeModule of
      Nothing -> []
      Just facade -> ["", "exposed-modules:", "    " <> facade]
    consumerBlocks
      | null ((.mappings) plan) = []
      | otherwise =
          [ "",
            "consumer-packages:"
          ]
            ++ map ("    " <>) ((.packages) plan)
            ++ [ "",
                 "consumer-modules:"
               ]
            ++ map ("    " <>) ((.modules) 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" : (.packages) (consumerPlanForService service) <> mappedShapeDependencies service <> concatMap (depsForNode service) ((.nodes) spec)))
  where
    spec = checkedSpec service

-- Generated structural shapes and codecs compile even when their primitive
-- dependencies are only reachable through a named mapping. Account for every
-- declaration here rather than asking each aggregate, queue, and query root to
-- rediscover the graph transitively.
mappedShapeDependencies :: CheckedService -> [Text]
mappedShapeDependencies service = case checkedTypeGraph service of
  Left _ -> []
  Right graph ->
    Set.toAscList
      ( Set.fromList
          [ package
          | ResolvedStructural _ shape <- Map.elems ((.declarations) graph),
            expression <- shapeExpressions shape,
            Right ConsumerTypePlan {imports = requirements} <- [planConsumerType graph expression],
            ImportRequirement {package} <- requirements
          ]
          <> Set.fromList ["keiro-core" | any usesOwnedCodec (expressions graph)]
          <> Set.fromList
            [ package
            | ResolvedStructural _ (RRefined Base16BytesV1) <- Map.elems ((.declarations) graph),
              package <- ["bytestring", "keiro-core"]
            ]
      )
  where
    expressions graph =
      [ expression
      | ResolvedStructural _ shape <- Map.elems ((.declarations) graph),
        expression <- shapeExpressions shape
      ]
    shapeExpressions =
      foldMappedShape
        MappedShapeAlgebra
          { onRecord = \_ _ fields -> map (.valueType) fields,
            onEnum = const [],
            onUnion = \_ arms -> [payload | arm <- arms, Just payload <- [(.payload) arm]],
            onBare = pure,
            onRefined = const []
          }
    usesOwnedCodec =
      foldTypeExpr
        TypeExprAlgebra
          { onText = False,
            onInt = False,
            onInteger = False,
            onBool = False,
            onNatural = False,
            onTime = False,
            onDay = True,
            onTextSet = True,
            onJson = False,
            onOptional = id,
            onList = id,
            onMap = id,
            onKeyedMap = \_ -> id,
            onRef = const False,
            onNominal = const False
          }

-- | 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 intake -> case (.idempotence) intake of
    IdemInboxTable -> integration
    IdemDelegated -> ["effectful-core", "keiro", "keiro-core", "text"]
  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
        [ case (.valueType) field of
            CTypeId prefix -> contractIdDomainContractFor (checkedLanguageContract service) prefix /= Nothing
            CDeclaredId {} -> True
            _ -> False
        | event <- (.events) contract,
          field <- (.fields) event
        ]

workqueueDependencies :: WorkqueueNode -> [Text]
workqueueDependencies workqueue =
  ["containers" | any (typeExprUses isContainer) expressions]
    <> ["text" | any (typeExprUses isTextSet) expressions]
    <> ["time" | any (typeExprUses isTime) expressions]
  where
    expressions = [expression | field <- (.payload) workqueue, TypedQueueExpression expression <- [(.valueType) field]]
    isContainer TMap {} = True
    isContainer TKeyedMap {} = True
    isContainer TTextSet = True
    isContainer _ = False
    isTextSet TTextSet = True
    isTextSet _ = False
    isTime TTime = True
    isTime TDay = 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
          TKeyedMap _ value -> typeExprUses predicate value
          _ -> False

readModelDependencies :: ReadModelNode -> [Text]
readModelDependencies readModel =
  ["aeson" | any (typeExprUses isJson) expressions]
    <> ["containers" | any (typeExprUses isContainer) expressions]
    <> ["text" | any (typeExprUses isTextSet) expressions]
    <> ["time" | any (typeExprUses isTime) expressions]
  where
    expressions = case (.queryTypes) readModel of
      Nothing -> []
      Just queryPair -> [(.input) queryPair, (.result) queryPair]
    isJson TJson = True
    isJson _ = False
    isContainer TMap {} = True
    isContainer TKeyedMap {} = True
    isContainer TTextSet = True
    isContainer _ = False
    isTextSet TTextSet = True
    isTextSet _ = False
    isTime TTime = True
    isTime TDay = 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
          TKeyedMap _ 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 {} <- [(.representation) nominal],
            ConsumerNominal {} <- [(.ownership) nominal]
          ]
    )
  where
    spec = checkedSpec service
    symbols = aggregateSymbolsFromGraphResult (checkedTypeGraph service) spec
    resolvedTypes =
      [ resolvedType
      | register <- (.regs) aggregate,
        Right resolvedType <- [resolveAggregateType symbols ((.loc) register) RegisterUse ((.valueType) register)]
      ]
        <> [ resolvedType
           | command <- (.commands) aggregate,
             field <- (.fields) command,
             Right resolvedType <- [inferAggregateFieldType symbols aggregate CommandFieldUse field]
           ]
        <> [ resolvedType
           | event <- (.events) aggregate,
             EventFields fields <- [(.body) event],
             field <- fields,
             Right resolvedType <- [inferAggregateFieldType symbols aggregate EventFieldUse field]
           ]