Dsls.hs

{-# LANGUAGE FlexibleContexts #-}

module Hydra.Sources.Kernel.Terms.Dsls where

-- Standard imports for kernel terms modules
import Hydra.Kernel
import Hydra.Sources.Libraries
import qualified Hydra.Dsl.Annotations       as Annotations
import qualified Hydra.Dsl.Meta.Core         as Core
import qualified Hydra.Dsl.Meta.Lib.Eithers  as Eithers
import qualified Hydra.Dsl.Meta.Lib.Equality as Equality
import qualified Hydra.Dsl.Meta.Lib.Lists    as Lists
import qualified Hydra.Dsl.Meta.Lib.Logic    as Logic
import qualified Hydra.Dsl.Meta.Lib.Maps     as Maps
import qualified Hydra.Dsl.Meta.Lib.Math     as Math
import qualified Hydra.Dsl.Meta.Lib.Maybes   as Maybes
import qualified Hydra.Dsl.Meta.Lib.Pairs    as Pairs
import           Hydra.Dsl.Meta.Lib.Strings  as Strings
import qualified Hydra.Dsl.Packaging       as Packaging
import qualified Hydra.Dsl.Meta.Phantoms     as Phantoms
import           Hydra.Dsl.Meta.Phantoms     as Phantoms hiding (
  elimination, field, fieldType, floatType, floatValue, function, injection, integerType, integerValue, lambda, literal,
  literalType, record, term, type_, typeScheme, wrap)
import qualified Hydra.Dsl.Terms             as Terms
import qualified Hydra.Dsl.Meta.Context      as Ctx
import qualified Hydra.Dsl.Errors       as Error
import           Hydra.Sources.Kernel.Types.All
import qualified Hydra.Sources.Kernel.Terms.Annotations as Annotations
import qualified Hydra.Sources.Kernel.Terms.Formatting as Formatting
import qualified Hydra.Sources.Kernel.Terms.Names as Names
import qualified Hydra.Sources.Kernel.Terms.Strip as Strip
import qualified Hydra.Dsl.Meta.DeepCore as DC
import           Hydra.Dsl.Meta.DeepCore ((@@@))
import           Prelude hiding ((++))
import qualified Data.List                   as L
import qualified Data.Map                    as M
import qualified Data.Set                    as S


ns :: Namespace
ns = Namespace "hydra.dsls"

module_ :: Module
module_ = Module {
            moduleNamespace = ns,
            moduleDefinitions = definitions,
            moduleTermDependencies = [Annotations.ns, Formatting.ns, Names.ns, Strip.ns],
            moduleTypeDependencies = kernelTypesNamespaces,
            moduleDescription = Just "Functions for generating domain-specific DSL modules from type modules"}
  where
    definitions = [
      toDefinition dslBindingName,
      toDefinition dslDefinitionName,
      toDefinition dslModule,
      toDefinition dslNamespace,
      toDefinition filterTypeBindings,
      toDefinition generateBindingsForType,
      toDefinition generateRecordAccessor,
      toDefinition generateRecordConstructor,
      toDefinition generateRecordWithUpdater,
      toDefinition generateUnionInjector,
      toDefinition generateWrappedTypeAccessors,
      toDefinition deduplicateBindings,
      toDefinition findUniqueName,
      toDefinition isDslEligibleBinding,
      toDefinition dslTypeScheme,
      toDefinition collectForallVars,
      toDefinition nominalResultType]

define :: String -> TTerm x -> TTermDefinition x
define = definitionInModule module_

-- | Wrap a type in TTerm: TypeApplication (TypeVariable "hydra.phantoms.TTerm") innerType
wrapInTTerm :: TTerm Type -> TTerm Type
wrapInTTerm t = Core.typeApplication $ Core.applicationType (Core.typeVariable (Core.nameLift _TTerm)) t

-- | Build a TypeScheme from a list of parameter types and a result type.
-- All types are wrapped in TTerm. Forall variables are collected from the original type.
dslTypeScheme :: TTermDefinition (Type -> [Type] -> Type -> TypeScheme)
dslTypeScheme = define "dslTypeScheme" $
  doc "Build a TypeScheme with TTerm-wrapped parameter and result types" $
  "origType" ~> "paramTypes" ~> "resultType" ~>
  "typeVars" <~ (collectForallVars @@ var "origType") $
  "wrappedResult" <~ (wrapInTTerm (var "resultType")) $
  "funType" <~ (Lists.foldr
    ("paramType" ~> "acc" ~> Core.typeFunction $ Core.functionType (wrapInTTerm (var "paramType")) (var "acc"))
    (var "wrappedResult")
    (var "paramTypes")) $
  Core.typeScheme (var "typeVars") (var "funType") nothing

-- | Collect forall type variables from a type (stripping annotations)
collectForallVars :: TTermDefinition (Type -> [Name])
collectForallVars = define "collectForallVars" $
  doc "Collect forall type variable names from a type" $
  "typ" ~> cases _Type (var "typ") (Just $ list ([] :: [TTerm Name])) [
    _Type_annotated>>: "at" ~>
      collectForallVars @@ Core.annotatedTypeBody (var "at"),
    _Type_forall>>: "ft" ~>
      Lists.cons (Core.forallTypeParameter (var "ft"))
        (collectForallVars @@ Core.forallTypeBody (var "ft"))]

-- | Build the nominal result type for a type definition.
-- For non-polymorphic types: TypeVariable typeName
-- For polymorphic types like (forall n. Namespaces n): TypeApplication (TypeVariable typeName) (TypeVariable n)
nominalResultType :: TTermDefinition (Name -> Type -> Type)
nominalResultType = define "nominalResultType" $
  doc "Build the nominal result type with type applications for forall variables" $
  "typeName" ~> "origType" ~>
  "vars" <~ (collectForallVars @@ var "origType") $
  Lists.foldl
    ("acc" ~> "v" ~> Core.typeApplication $ Core.applicationType (var "acc") (Core.typeVariable (var "v")))
    (Core.typeVariable (var "typeName"))
    (var "vars")

-- | Inject a Record-typed term into the Term.record variant
-- Produces TermInject(Injection _Term (Field _Term_record innerRecord))
injectTermRecord :: TTerm Term -> TTerm Term
injectTermRecord t = Core.termInject $ Core.injection (Core.nameLift _Term) (Core.field (Core.nameLift _Term_record) t)

-- | Inject a term into the Term.application variant
injectTermApplication :: TTerm Term -> TTerm Term
injectTermApplication t = Core.termInject $ Core.injection (Core.nameLift _Term) (Core.field (Core.nameLift _Term_application) t)

-- | Inject a term into the Term.cases variant
injectTermCases :: TTerm Term -> TTerm Term
injectTermCases t = Core.termInject $ Core.injection (Core.nameLift _Term) (Core.field (Core.nameLift _Term_cases) t)

-- | Inject a term into the Term.project variant
injectTermProject :: TTerm Term -> TTerm Term
injectTermProject t = Core.termInject $ Core.injection (Core.nameLift _Term) (Core.field (Core.nameLift _Term_project) t)

-- | Inject a term into the Term.union variant
injectTermUnion :: TTerm Term -> TTerm Term
injectTermUnion t = Core.termInject $ Core.injection (Core.nameLift _Term) (Core.field (Core.nameLift _Term_inject) t)

-- | Inject a term into the Term.unwrap variant
injectTermUnwrap :: TTerm Term -> TTerm Term
injectTermUnwrap t = Core.termInject $ Core.injection (Core.nameLift _Term) (Core.field (Core.nameLift _Term_unwrap) t)

-- | Inject a term into the Term.wrap variant
injectTermWrap :: TTerm Term -> TTerm Term
injectTermWrap t = Core.termInject $ Core.injection (Core.nameLift _Term) (Core.field (Core.nameLift _Term_wrap) t)

-- | Build a deep Name: TermWrap(_Name, TermLiteral(LiteralString(s)))
deepName :: TTerm String -> TTerm Term
deepName s = Core.termWrap $ Core.wrappedTerm (Core.nameLift _Name) (Core.termLiteral $ Core.literalString s)

-- | Build a deep Projection as a Term value
deepProjection :: TTerm Name -> TTerm Name -> TTerm Term
deepProjection typeName fieldName =
  injectTermProject $
    Core.termRecord $ Core.record (Core.nameLift _Projection) (list [
      Core.field (Core.nameLift _Projection_typeName) (deepName (Core.unName typeName)),
      Core.field (Core.nameLift _Projection_field) (deepName (Core.unName fieldName))])

-- | Build a deep Application as a Term value
deepApplication :: TTerm Term -> TTerm Term -> TTerm Term
deepApplication fun arg =
  injectTermApplication $
    Core.termRecord $ Core.record (Core.nameLift _Application) (list [
      Core.field (Core.nameLift _Application_function) fun,
      Core.field (Core.nameLift _Application_argument) arg])

-- | Build a deep Field record
deepField :: TTerm Name -> TTerm Term -> TTerm Term
deepField name term =
  Core.termRecord $ Core.record (Core.nameLift _Field) (list [
    Core.field (Core.nameLift _Field_name) (deepName (Core.unName name)),
    Core.field (Core.nameLift _Field_term) term])

-- | Build a deep Record as a Term value (injected into Term.record)
deepRecord :: TTerm Name -> TTerm [Term] -> TTerm Term
deepRecord typeName fields =
  injectTermRecord $
    Core.termRecord $ Core.record (Core.nameLift _Record) (list [
      Core.field (Core.nameLift _Record_typeName) (deepName (Core.unName typeName)),
      Core.field (Core.nameLift _Record_fields) (Core.termList fields)])

-- | Build a deep Injection as a Term value (injected into Term.union)
deepInjection :: TTerm Name -> TTerm Term -> TTerm Term
deepInjection typeName fieldTerm =
  injectTermUnion $
    Core.termRecord $ Core.record (Core.nameLift _Injection) (list [
      Core.field (Core.nameLift _Injection_typeName) (deepName (Core.unName typeName)),
      Core.field (Core.nameLift _Injection_field) fieldTerm])

-- | Build a deep WrappedTerm as a Term value (injected into Term.wrap)
deepWrap :: TTerm Name -> TTerm Term -> TTerm Term
deepWrap typeName body =
  injectTermWrap $
    Core.termRecord $ Core.record (Core.nameLift _WrappedTerm) (list [
      Core.field (Core.nameLift _WrappedTerm_typeName) (deepName (Core.unName typeName)),
      Core.field (Core.nameLift _WrappedTerm_body) body])

-- | Build a deep TermUnwrap value
deepUnwrap :: TTerm Name -> TTerm Term
deepUnwrap typeName =
  injectTermUnwrap $
    deepName (Core.unName typeName)

-- | Unwrap a TTerm argument: apply (TermUnwrap _TTerm) to the variable
unwrapTTerm :: TTerm Term -> TTerm Term
unwrapTTerm v = Core.termApplication $ Core.application
  (Core.termUnwrap (Core.nameLift _TTerm))
  v

-- | Wrap a term in TTerm: WrappedTerm _TTerm term
wrapTermInTTerm :: TTerm Term -> TTerm Term
wrapTermInTTerm t = Core.termWrap $ Core.wrappedTerm (Core.nameLift _TTerm) t



-- | Generate a DSL module namespace from a source module namespace
-- For example, "hydra.core" -> "hydra.dsl.core"
dslNamespace :: TTermDefinition (Namespace -> Namespace)
dslNamespace = define "dslNamespace" $
  doc "Generate a DSL module namespace from a source module namespace" $
  "ns" ~>
  "parts" <~ (Strings.splitOn (string ".") (Packaging.unNamespace (var "ns"))) $
  "prefixFull" <~ (Packaging.namespace (Strings.cat $ list [
    string "hydra.dsl.",
    Packaging.unNamespace (var "ns")])) $
  -- For hydra.* namespaces: hydra.foo -> hydra.dsl.foo
  -- For other namespaces: foo.bar -> hydra.dsl.foo.bar (preserve full path)
  -- An empty parts list is unreachable for a well-formed namespace; fall back
  -- to the full-prefix form.
  Maybes.maybe
    (var "prefixFull")
    ("ht" ~>
      Logic.ifElse (Equality.equal (Pairs.first (var "ht")) (string "hydra"))
        (Packaging.namespace (Strings.cat $ list [
          string "hydra.dsl.",
          Strings.intercalate (string ".") (Pairs.second (var "ht"))]))
        (var "prefixFull"))
    (Lists.uncons (var "parts"))

-- | Generate a fully qualified binding name for a DSL function from a type name
-- For example, "hydra.core.AnnotatedTerm" -> "hydra.dsl.core.annotatedTerm"
-- For local types (no namespace), returns just the decapitalized local name
dslBindingName :: TTermDefinition (Name -> Name)
dslBindingName = define "dslBindingName" $
  doc "Generate a binding name for a DSL function from a type name" $
  "n" ~>
  "parts" <~ (Strings.splitOn (string ".") (Core.unName (var "n"))) $
  "localPart" <~ (Formatting.decapitalize @@ (Names.localNameOf @@ (var "n"))) $
  "localResult" <~ (Core.name (var "localPart")) $
  -- nsParts = parts minus the last element (the namespace components).
  -- Nothing means parts was empty (unreachable for a valid name);
  -- Just [] means the name has no namespace (local type).
  Maybes.maybe
    (var "localResult")
    ("nsParts" ~>
      Maybes.maybe
        -- single-element parts: local type, no namespace
        (var "localResult")
        ("nsHeadTail" ~>
          "dslNsParts" <~ (Logic.ifElse
            (Equality.equal (Pairs.first (var "nsHeadTail")) (string "hydra"))
            -- hydra.core.Foo -> [hydra, dsl] ++ tail nsParts
            (Lists.concat2 (list [string "hydra", string "dsl"]) (Pairs.second (var "nsHeadTail")))
            -- openGql.grammar.Foo -> [hydra, dsl] ++ nsParts
            (Lists.concat2 (list [string "hydra", string "dsl"]) (var "nsParts"))) $
          Core.name (Strings.intercalate (string ".")
            (Lists.concat2 (var "dslNsParts") (list [var "localPart"]))))
        (Lists.uncons (var "nsParts")))
    (Lists.maybeInit (var "parts"))

-- | Generate a DSL element name from a type name and a local element name.
-- For example, ("hydra.core.AnnotatedTerm", "annotatedTermBody") -> "hydra.dsl.core.annotatedTermBody"
-- This extracts the namespace from the type name, transforms it to the DSL namespace,
-- and appends the local element name.
dslDefinitionName :: TTermDefinition (Name -> String -> Name)
dslDefinitionName = define "dslDefinitionName" $
  doc "Generate a qualified DSL element name from a type name and local element name" $
  "typeName" ~> "localName" ~>
  "parts" <~ (Strings.splitOn (string ".") (Core.unName (var "typeName"))) $
  -- Extract namespace parts (all but last); fall back to the bare local name
  -- when the type name has no namespace (unreachable for well-formed inputs).
  Maybes.maybe
    (Core.name (var "localName"))
    ("nsParts" ~>
      "dslNsParts" <~ (Maybes.maybe
        -- nsParts empty: just prepend hydra.dsl
        (list [string "hydra", string "dsl"])
        ("nsHeadTail" ~> Logic.ifElse
          (Equality.equal (Pairs.first (var "nsHeadTail")) (string "hydra"))
          -- hydra.core -> hydra.dsl.core (drop the leading "hydra", keep the rest)
          (Lists.concat2 (list [string "hydra", string "dsl"]) (Pairs.second (var "nsHeadTail")))
          -- openGql.grammar -> hydra.dsl.openGql.grammar
          (Lists.concat2 (list [string "hydra", string "dsl"]) (var "nsParts")))
        (Lists.uncons (var "nsParts"))) $
      Core.name (Strings.intercalate (string ".")
        (Lists.concat2 (var "dslNsParts") (list [var "localName"]))))
    (Lists.maybeInit (var "parts"))

-- | Generate a record constructor function.
-- For a record type like {body: Term, annotation: Map(Name, Term)},
-- produces a deep (meta) term:
--   \body -> \annotation -> TermRecord (Record "hydra.core.AnnotatedTerm" [Field "body" body, ...])
-- When code-generated into Haskell, this becomes:
--   annotatedTerm body annotation = Core.TermRecord (Core.Record { ... })
generateRecordConstructor :: TTermDefinition (Type -> Name -> [FieldType] -> [Binding])
generateRecordConstructor = define "generateRecordConstructor" $
  doc "Generate a record constructor function" $
  "origType" ~> "typeName" ~> "fieldTypes" ~>
  -- Build deep fields and record using helpers
  "dFields" <~ (Lists.map
    ("ft" ~> deepField (Core.fieldTypeName (var "ft"))
      (unwrapTTerm (Core.termVariable (Core.name (Formatting.decapitalize @@ (Names.localNameOf @@ Core.fieldTypeName (var "ft")))))))
    (var "fieldTypes")) $
  "recordTerm" <~ (wrapTermInTTerm (deepRecord (var "typeName") (var "dFields"))) $
  -- Build (paramName, TTerm<fieldType>) pairs for lambda construction
  "paramPairs" <~ (Lists.map
    ("ft" ~> pair
      (Formatting.decapitalize @@ (Names.localNameOf @@ Core.fieldTypeName (var "ft")))
      (wrapInTTerm (Core.fieldTypeType (var "ft"))))
    (var "fieldTypes")) $
  -- Wrap in typed lambdas for each parameter (right to left)
  "body" <~ (Lists.foldl
    ("acc" ~> "pp" ~>
      Core.termLambda $ Core.lambda (Core.name (Pairs.first (var "pp"))) (just (Pairs.second (var "pp"))) (var "acc"))
    (var "recordTerm")
    (Lists.reverse (var "paramPairs"))) $
  -- Type: TTerm<FieldType1> -> TTerm<FieldType2> -> ... -> TTerm<RecordType>
  "paramTypes" <~ (Lists.map ("ft" ~> Core.fieldTypeType (var "ft")) (var "fieldTypes")) $
  "resultType" <~ (nominalResultType @@ var "typeName" @@ var "origType") $
  "ts" <~ (dslTypeScheme @@ var "origType" @@ var "paramTypes" @@ var "resultType") $
  -- Return as a single-element list with the constructor binding
  list [Core.binding
    (dslBindingName @@ var "typeName")
    (var "body")
    (just (var "ts"))]

-- | Generate a record field accessor function.
-- For a field "name" in record type "Binding", produces:
--   bindingName :: Binding -> Name
--   bindingName x = x.name
generateRecordAccessor :: TTermDefinition (Type -> Name -> FieldType -> Binding)
generateRecordAccessor = define "generateRecordAccessor" $
  doc "Generate a record field accessor function" $
  "origType" ~> "typeName" ~> "ft" ~>
  "fieldName" <~ (Core.fieldTypeName (var "ft")) $
  "accessorLocalName" <~ (Strings.cat $ list [
    Formatting.decapitalize @@ (Names.localNameOf @@ var "typeName"),
    Strings.intercalate (string "") (Lists.map ("s" ~> Formatting.capitalize @@ var "s") (Strings.splitOn (string ".") (Core.unName (var "fieldName"))))]) $
  "accessorName" <~ (dslDefinitionName @@ var "typeName" @@ var "accessorLocalName") $
  -- Body: projection as a simple elimination
  "paramDomain" <~ (wrapInTTerm (nominalResultType @@ var "typeName" @@ var "origType")) $
  "body" <~ (Core.termLambda $ Core.lambda (Core.name (string "x")) (just (var "paramDomain")) $
      wrapTermInTTerm (deepApplication
        (deepProjection (var "typeName") (var "fieldName"))
        (unwrapTTerm (Core.termVariable (Core.name (string "x")))))) $
  "ts" <~ (dslTypeScheme @@ var "origType"
    @@ list [nominalResultType @@ var "typeName" @@ var "origType"]
    @@ Core.fieldTypeType (var "ft")) $
  Core.binding
    (var "accessorName")
    (var "body")
    (just (var "ts"))

-- | Generate a "withXxx" record field updater function.
-- For a field "name" in record type "Binding" (with fields name, term, type), produces:
--   bindingWithName :: Binding -> Name -> Binding
--   bindingWithName b newName = Binding newName (bindingTerm b) (bindingType b)
-- This constructs a new record with the specified field replaced and all others projected.
generateRecordWithUpdater :: TTermDefinition (Type -> Name -> [FieldType] -> FieldType -> Binding)
generateRecordWithUpdater = define "generateRecordWithUpdater" $
  doc "Generate a withXxx record field updater function" $
  "origType" ~> "typeName" ~> "allFields" ~> "targetField" ~>
  "targetFieldName" <~ (Core.fieldTypeName (var "targetField")) $
  -- Build the updater name: e.g., "bindingWithName"
  "updaterLocalName" <~ (Strings.cat $ list [
    Formatting.decapitalize @@ (Names.localNameOf @@ var "typeName"),
    string "With",
    Strings.intercalate (string "") (Lists.map ("s" ~> Formatting.capitalize @@ var "s") (Strings.splitOn (string ".") (Core.unName (var "targetFieldName"))))]) $
  "updaterName" <~ (dslDefinitionName @@ var "typeName" @@ var "updaterLocalName") $
  -- Build deep fields: project from unwrapped original, except target uses unwrapped newVal
  "dFields" <~ (Lists.map
    ("ft" ~> deepField (Core.fieldTypeName (var "ft"))
      (Logic.ifElse (Equality.equal
        (Core.unName (Core.fieldTypeName (var "ft")))
        (Core.unName (var "targetFieldName")))
        (unwrapTTerm (Core.termVariable (Core.name (string "newVal"))))
        (deepApplication
          (deepProjection (var "typeName") (Core.fieldTypeName (var "ft")))
          (unwrapTTerm (Core.termVariable (Core.name (string "original")))))))
    (var "allFields")) $
  "recDomain" <~ (wrapInTTerm (nominalResultType @@ var "typeName" @@ var "origType")) $
  "fieldDomain" <~ (wrapInTTerm (Core.fieldTypeType (var "targetField"))) $
  "body" <~ (
    Core.termLambda $ Core.lambda (Core.name (string "original")) (just (var "recDomain")) $
    Core.termLambda $ Core.lambda (Core.name (string "newVal")) (just (var "fieldDomain")) $
    wrapTermInTTerm (deepRecord (var "typeName") (var "dFields"))) $
  "recType" <~ (nominalResultType @@ var "typeName" @@ var "origType") $
  "ts" <~ (dslTypeScheme @@ var "origType"
    @@ list [var "recType", Core.fieldTypeType (var "targetField")]
    @@ var "recType") $
  Core.binding
    (var "updaterName")
    (var "body")
    (just (var "ts"))

-- | Generate a union injection helper.
-- For a variant "lambda" in union type "Function", produces:
--   functionLambda :: Lambda -> Function
--   functionLambda x = Function.lambda x
-- For unit variants (field type is unit), produces:
--   comparisonLessThan :: Comparison
--   comparisonLessThan = Comparison.lessThan ()
generateUnionInjector :: TTermDefinition (Type -> Name -> FieldType -> Binding)
generateUnionInjector = define "generateUnionInjector" $
  doc "Generate a union injection helper" $
  "origType" ~> "typeName" ~> "ft" ~>
  "fieldName" <~ (Core.fieldTypeName (var "ft")) $
  "fieldType" <~ (Core.fieldTypeType (var "ft")) $
  -- Build the injector name: e.g., "functionLambda" or "comparisonLessThan"
  "injectorLocalName" <~ (Strings.cat $ list [
    Formatting.decapitalize @@ (Names.localNameOf @@ var "typeName"),
    Strings.intercalate (string "") (Lists.map ("s" ~> Formatting.capitalize @@ var "s") (Strings.splitOn (string ".") (Core.unName (var "fieldName"))))]) $
  "injectorName" <~ (dslDefinitionName @@ var "typeName" @@ var "injectorLocalName") $
  -- Check if field type is unit (for unit variants like enum members)
  "isUnit" <~ (isUnitType_ @@ var "fieldType") $
  -- Build simple injection
  -- Build deep injection: deepField for the variant, then deepInjection into the union type
  "dFieldValue" <~ (Logic.ifElse (var "isUnit")
    (Core.termInject $ Core.injection (Core.nameLift _Term) (Core.field (Core.nameLift _Term_unit) Core.termUnit))
    (unwrapTTerm (Core.termVariable (Core.name (string "x"))))) $
  "injectionTerm" <~ (wrapTermInTTerm (deepInjection (var "typeName") (deepField (var "fieldName") (var "dFieldValue")))) $
  -- For non-unit variants, wrap in a typed lambda; for unit, it's a constant TTerm
  "variantDomain" <~ (wrapInTTerm (Core.fieldTypeType (var "ft"))) $
  "body" <~ (Logic.ifElse (var "isUnit")
    (var "injectionTerm")
    (Core.termLambda $ Core.lambda (Core.name (string "x")) (just (var "variantDomain")) (var "injectionTerm"))) $
  "unionType" <~ (nominalResultType @@ var "typeName" @@ var "origType") $
  "ts" <~ (Logic.ifElse (var "isUnit")
    (dslTypeScheme @@ var "origType" @@ list ([] :: [TTerm Type]) @@ var "unionType")
    (dslTypeScheme @@ var "origType" @@ list [Core.fieldTypeType (var "ft")] @@ var "unionType")) $
  Core.binding
    (var "injectorName")
    (var "body")
    (just (var "ts"))

-- | Check if a type is the unit type (stripping annotations first)
-- Note: uses stripAnnotations to avoid recursive Haskell-level DSL terms,
-- which would cause infinite recursion during code generation.
isUnitType_ :: TTerm (Type -> Bool)
isUnitType_ = "t" ~> cases _Type (Strip.deannotateType @@ var "t") (Just Phantoms.false) [
  _Type_unit>>: constant Phantoms.true]

-- | Generate wrap/unwrap accessors for a wrapped type.
-- For a wrapped type like "Name" wrapping String, produces:
--   name :: String -> Name      (constructor/wrap)
--   unName :: Name -> String    (unwrap)
generateWrappedTypeAccessors :: TTermDefinition (Type -> Name -> Type -> [Binding])
generateWrappedTypeAccessors = define "generateWrappedTypeAccessors" $
  doc "Generate wrap/unwrap accessors for a wrapped type" $
  "origType" ~> "typeName" ~> "innerType" ~>
  "localName" <~ (Names.localNameOf @@ var "typeName") $
  -- Wrap function: decapitalized type name
  "wrapName" <~ (dslDefinitionName @@ var "typeName" @@ (Formatting.decapitalize @@ var "localName")) $
  -- Unwrap function: "un" + type local name
  "unwrapLocalName" <~ (Strings.cat $ list [string "un", var "localName"]) $
  "unwrapName" <~ (dslDefinitionName @@ var "typeName" @@ var "unwrapLocalName") $
  "wrapperType" <~ (nominalResultType @@ var "typeName" @@ var "origType") $
  -- Wrap: \(x :: TTerm<InnerType>) -> WrappedTerm typeName x
  "wrapDomain" <~ (wrapInTTerm (var "innerType")) $
  "wrapBody" <~ (
    Core.termLambda $ Core.lambda (Core.name (string "x")) (just (var "wrapDomain")) $
        wrapTermInTTerm (deepWrap (var "typeName")
          (unwrapTTerm (Core.termVariable (Core.name (string "x")))))) $
  -- Unwrap: \(x :: TTerm<WrapperType>) -> TTerm(apply (unwrap typeName) (unTTerm x))
  "unwrapDomain" <~ (wrapInTTerm (var "wrapperType")) $
  "unwrapBody" <~ (
    Core.termLambda $ Core.lambda (Core.name (string "x")) (just (var "unwrapDomain")) $
        wrapTermInTTerm (deepApplication
          (deepUnwrap (var "typeName"))
          (unwrapTTerm (Core.termVariable (Core.name (string "x")))))) $
  "wrapTs" <~ (dslTypeScheme @@ var "origType" @@ list [var "innerType"] @@ var "wrapperType") $
  "unwrapTs" <~ (dslTypeScheme @@ var "origType" @@ list [var "wrapperType"] @@ var "innerType") $
  list [
    Core.binding (var "wrapName") (var "wrapBody") (just (var "wrapTs")),
    Core.binding (var "unwrapName") (var "unwrapBody") (just (var "unwrapTs"))]

-- | Generate all DSL bindings for a single type binding.
-- Inspects the type definition and generates appropriate helpers:
-- - Records: constructor + accessors + withXxx updaters
-- - Unions: injection helpers
-- - Wrapped types: wrap + unwrap
generateBindingsForType :: TTermDefinition (Context -> Graph -> Binding -> Either DecodingError [Binding])
generateBindingsForType = define "generateBindingsForType" $
  doc "Generate all DSL bindings for a type binding" $
  "cx" ~> "graph" ~> "b" ~>
  "typeName" <~ (Core.bindingName (var "b")) $
  Eithers.bind (decoderFor _Type @@ var "graph" @@ (Core.bindingTerm (var "b"))) (
    "rawType" ~>
    "typ" <~ (Strip.deannotateTypeParameters @@ (Strip.deannotateType @@ var "rawType")) $
    right (cases _Type (var "typ") (Just $ list ([] :: [TTerm Binding])) [
      _Type_record>>: "fts" ~>
        Lists.concat $ list [
          generateRecordConstructor @@ var "rawType" @@ var "typeName" @@ var "fts",
          Lists.map (generateRecordAccessor @@ var "rawType" @@ var "typeName") (var "fts"),
          Lists.map (generateRecordWithUpdater @@ var "rawType" @@ var "typeName" @@ var "fts")
            (var "fts")],
      _Type_union>>: "fts" ~>
        Lists.map (generateUnionInjector @@ var "rawType" @@ var "typeName") (var "fts"),
      _Type_wrap>>: "innerType" ~>
        generateWrappedTypeAccessors @@ var "rawType" @@ var "typeName" @@ var "innerType"]))

-- | Deduplicate bindings by appending "_" suffixes to duplicate names.
-- Later bindings get suffixes; earlier ones keep their name.
-- Multiple duplicates get increasing suffixes: name_, name__, name___, etc.
deduplicateBindings :: TTermDefinition ([Binding] -> [Binding])
deduplicateBindings = define "deduplicateBindings" $
  doc "Deduplicate bindings by appending underscore suffixes to duplicate names" $
  "bindings" ~>
  Lists.foldl
    ("acc" ~> "b" ~>
      "n" <~ (Core.unName (Core.bindingName (var "b"))) $
      "usedNames" <~ (Lists.map ("a" ~> Core.unName (Core.bindingName (var "a"))) (var "acc")) $
      "uniqueName" <~ (findUniqueName @@ var "n" @@ var "usedNames") $
      Lists.concat2 (var "acc") (list [
        Core.binding
          (Core.name (var "uniqueName"))
          (Core.bindingTerm (var "b"))
          (Core.bindingTypeScheme (var "b"))]))
    (list ([] :: [TTerm Binding]))
    (var "bindings")

-- | Find a unique name by appending "_" suffixes until not in the used list
findUniqueName :: TTermDefinition (String -> [String] -> String)
findUniqueName = define "findUniqueName" $
  doc "Find a unique name by appending underscores" $
  "candidate" ~> "usedNames" ~>
  Logic.ifElse (Lists.null (Lists.filter (unaryFunction (Equality.equal (var "candidate"))) (var "usedNames")))
    (var "candidate")
    (findUniqueName @@ (Strings.cat $ list [var "candidate", string "_"]) @@ var "usedNames")

-- | Filter bindings to only DSL-eligible type definitions
filterTypeBindings :: TTermDefinition (Context -> Graph -> [Binding] -> Either Error [Binding])
filterTypeBindings = define "filterTypeBindings" $
  doc "Filter bindings to only DSL-eligible type definitions" $
  "cx" ~> "graph" ~> "bindings" ~>
    Eithers.map (primitive _maybes_cat) $
      Eithers.mapList (isDslEligibleBinding @@ var "cx" @@ var "graph") $
        primitive _lists_filter @@ Annotations.isNativeType @@ var "bindings"

-- | Check if a binding is eligible for DSL generation.
-- Excludes phantom types (TTerm, TBinding) since they are meta-infrastructure.
isDslEligibleBinding :: TTermDefinition (Context -> Graph -> Binding -> Either Error (Maybe Binding))
isDslEligibleBinding = define "isDslEligibleBinding" $
  doc "Check if a binding is eligible for DSL generation" $
  "cx" ~> "graph" ~> "b" ~>
  "ns" <~ (Names.namespaceOf @@ Core.bindingName (var "b")) $
  Logic.ifElse (Equality.equal (Maybes.maybe (string "") (unaryFunction Packaging.unNamespace) (var "ns")) (string "hydra.phantoms"))
    (right nothing)
    (right (just (var "b")))

-- | Transform a type module into a DSL module.
-- Returns Nothing if the module has no eligible type definitions.
dslModule :: TTermDefinition (Context -> Graph -> Module -> Either Error (Maybe Module))
dslModule = define "dslModule" $
  doc "Transform a type module into a DSL module" $
  "cx" ~> "graph" ~> "mod" ~>
    "typeBindings" <<~ (filterTypeBindings @@ var "cx" @@ var "graph" @@
      (Maybes.cat $ Lists.map
        ("d" ~> cases _Definition (var "d") (Just nothing) [
          _Definition_type>>: "td" ~>
            just (Annotations.typeBinding @@ (Packaging.typeDefinitionName $ var "td") @@ (Core.typeSchemeBody $ Packaging.typeDefinitionTypeScheme $ var "td"))])
        (Packaging.moduleDefinitions (var "mod")))) $
    Logic.ifElse (Lists.null (var "typeBindings"))
      (right nothing)
      ("dslBindings" <<~ Eithers.mapList ("b" ~>
        Eithers.bimap
          ("_e" ~> Error.errorDecoding $ var "_e")
          ("x" ~> var "x")
          (generateBindingsForType @@ var "cx" @@ var "graph" @@ var "b")) (var "typeBindings") $
        right (just (Packaging.module_
          (just (Strings.cat $ list [
            string "DSL functions for ",
            Packaging.unNamespace (Packaging.moduleNamespace (var "mod"))]))
          (dslNamespace @@ (Packaging.moduleNamespace (var "mod")))
          -- DSL modules depend on DSL modules for type dependencies (to reference other types' DSL functions)
          (Lists.nub (primitive _lists_map @@ dslNamespace @@ (Packaging.moduleTypeDependencies (var "mod"))))
          -- Type dependencies: the original module + its type deps + hydra.phantoms (for TTerm)
          (Lists.nub (Lists.concat2
            (list [Packaging.moduleNamespace (var "mod"), Packaging.namespace (string "hydra.phantoms")])
            (Packaging.moduleTypeDependencies (var "mod"))))
          (Lists.map ("b" ~> Packaging.definitionTerm (Packaging.termDefinition
            (Core.bindingName $ var "b") (Core.bindingTerm $ var "b")
            (Core.bindingTypeScheme $ var "b")))
            (deduplicateBindings @@ Lists.concat (var "dslBindings"))))))