!import "prelude" !Local
!import "view" !Local

-- Stdlib-shaped typed-program catalog. These helpers are stable lowering
-- targets for frontend-emitted API contracts. They are monomorphic
-- instantiations of familiar polymorphic shapes.
listMapUseContract = (elemIn elemOut mapSym fnSym xsSym partialSym outSym :
  typedProgram
    outSym
    [(typedDeclareFn
       mapSym
       [(viewFn [(elemIn)] elemOut) (viewList elemIn)]
       (viewList elemOut)
       t)
     (typedDeclareFn fnSym [(elemIn)] elemOut t)
     (typedValue xsSym (viewList elemIn) t)
     (typedApply partialSym mapSym fnSym t)
     (typedApply outSym partialSym xsSym t)
     (typedRequire outSym (viewList elemOut) t)])

headMaybeUseContract = (elem headSym xsSym outSym :
  typedProgram
    outSym
    [(typedDeclareFn headSym [(viewList elem)] (viewMaybe elem) t)
     (typedValue xsSym (viewList elem) t)
     (typedApply outSym headSym xsSym t)
     (typedRequire outSym (viewMaybe elem) t)])

listFilterUseContract = (elem filterSym predSym xsSym partialSym outSym :
  typedProgram
    outSym
    [(typedDeclareFn
       filterSym
       [(viewFn [(elem)] viewBool) (viewList elem)]
       (viewList elem)
       t)
     (typedDeclareFn predSym [(elem)] viewBool t)
     (typedValue xsSym (viewList elem) t)
     (typedApply partialSym filterSym predSym t)
     (typedApply outSym partialSym xsSym t)
     (typedRequire outSym (viewList elem) t)])

listFoldUseContract = (acc elem foldSym fnSym initSym xsSym partialFnSym partialInitSym outSym :
  typedProgram
    outSym
    [(typedDeclareFn
       foldSym
       [(viewFn [(acc) (elem)] acc) acc (viewList elem)]
       acc
       t)
     (typedDeclareFn fnSym [(acc) (elem)] acc t)
     (typedValue initSym acc t)
     (typedValue xsSym (viewList elem) t)
     (typedApply partialFnSym foldSym fnSym t)
     (typedApply partialInitSym partialFnSym initSym t)
     (typedApply outSym partialInitSym xsSym t)
     (typedRequire outSym acc t)])

listMapMaybeUseContract = (elemIn elemOut mapMaybeSym fnSym xsSym partialSym outSym :
  typedProgram
    outSym
    [(typedDeclareFn
       mapMaybeSym
       [(viewFn [(elemIn)] (viewMaybe elemOut)) (viewList elemIn)]
       (viewList elemOut)
       t)
     (typedDeclareFn fnSym [(elemIn)] (viewMaybe elemOut) t)
     (typedValue xsSym (viewList elemIn) t)
     (typedApply partialSym mapMaybeSym fnSym t)
     (typedApply outSym partialSym xsSym t)
     (typedRequire outSym (viewList elemOut) t)])

-- Concrete stdlib-shaped typed programs. These are deliberately monomorphic
-- examples of the shapes a frontend can emit for polymorphic library functions.
listMapBoolStringExpr = cFn <|
    [(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString)
    |> cApply (cFn [(viewBool)] viewString)
    |> cApply (cValue (viewList viewBool))
    |> cRequire (viewList viewString)

headMaybeBoolExpr = cFn <|
    [(viewList viewBool)] (viewMaybe viewBool)
    |> cApply (cValue (viewList viewBool))
    |> cRequire (viewMaybe viewBool)

listFilterBoolExpr = cFn <|
    [(viewFn [(viewBool)] viewBool) (viewList viewBool)] (viewList viewBool)
    |> cApply (cFn [(viewBool)] viewBool)
    |> cApply (cValue (viewList viewBool))
    |> cRequire (viewList viewBool)

listFoldStringBoolExpr = cFn <|
    [(viewFn [(viewString) (viewBool)] viewString) viewString (viewList viewBool)] viewString
    |> cApply (cFn [(viewString) (viewBool)] viewString)
    |> cApply (cValue viewString)
    |> cApply (cValue (viewList viewBool))
    |> cRequire viewString

listMapMaybeBoolStringExpr = cFn <|
    [(viewFn [(viewBool)] (viewMaybe viewString)) (viewList viewBool)] (viewList viewString)
    |> cApply (cFn [(viewBool)] (viewMaybe viewString))
    |> cApply (cValue (viewList viewBool))
    |> cRequire (viewList viewString)

-- Keep catalog exports as explicit finite typed-programs. `cCompileAt` is useful
-- as a frontend-emission helper, but forcing generated node lists at module
-- import time can violate top-level normalization discipline.
listMapBoolStringContract =
  listMapUseContract viewBool viewString 100 101 102 103 104
headMaybeBoolContract =
  headMaybeUseContract viewBool 110 111 112
listFilterBoolContract =
  listFilterUseContract viewBool 120 121 122 123 124
listFoldStringBoolContract =
  listFoldUseContract viewString viewBool 130 131 132 133 134 135 136
listMapMaybeBoolStringContract =
  listMapMaybeUseContract viewBool viewString 140 141 142 143 144

listMapWrongFunctionArgContract =
  typedProgram
    152
    [(typedDeclareFn
       150
       [(viewFn [(viewBool)] viewString) (viewList viewBool)]
       (viewList viewString)
       t)
     (typedDeclareFn 151 [(viewString)] viewString t)
     (typedApply 152 150 151 t)]

listMapWrongListArgContract =
  typedProgram
    164
    [(typedDeclareFn
       160
       [(viewFn [(viewBool)] viewString) (viewList viewBool)]
       (viewList viewString)
       t)
     (typedDeclareFn 161 [(viewBool)] viewString t)
     (typedValue 162 (viewList viewString) t)
     (typedApply 163 160 161 t)
     (typedApply 164 163 162 t)]

listMapWrongOutputContract =
  typedProgram
    174
    [(typedDeclareFn
       170
       [(viewFn [(viewBool)] viewString) (viewList viewBool)]
       (viewList viewString)
       t)
     (typedDeclareFn 171 [(viewBool)] viewString t)
     (typedValue 172 (viewList viewBool) t)
     (typedApply 173 170 171 t)
     (typedApply 174 173 172 t)
     (typedRequire 174 (viewList viewBool) t)]

listFilterWrongPredicateContract =
  typedProgram
    182
    [(typedDeclareFn
       180
       [(viewFn [(viewBool)] viewBool) (viewList viewBool)]
       (viewList viewBool)
       t)
     (typedDeclareFn 181 [(viewBool)] viewString t)
     (typedApply 182 180 181 t)]

listMapWrongListArgExpr = cFn <|
    [(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString)
    |> cApply (cFn [(viewBool)] viewString)
    |> cApply (cValue (viewList viewString))
    |> cRequire (viewList viewString)

listMapWrongListArgExprContract =
  typedProgram
    194
    [(typedDeclareFn
       190
       [(viewFn [(viewBool)] viewString) (viewList viewBool)]
       (viewList viewString)
       t)
     (typedDeclareFn 191 [(viewBool)] viewString t)
     (typedValue 193 (viewList viewString) t)
     (typedApply 192 190 191 t)
     (typedApply 194 192 193 t)
     (typedRequire 194 (viewList viewString) t)]

viewCatalogSelfTests =
  append
    viewContractSelfTests
    [ (typedContractCheck listMapBoolStringContract)
      (typedContractCheck headMaybeBoolContract)
      (typedContractCheck listFilterBoolContract)
      (typedContractCheck listFoldStringBoolContract)
      (typedContractCheck listMapMaybeBoolStringContract)
      (viewContractExpectResult
        "function argument view is not known"
        (checkTypedProgramWith policyStrict listMapWrongFunctionArgContract))
      (viewContractExpectResult
        "function argument view is not known"
        (checkTypedProgramWith policyStrict listMapWrongListArgContract))
      (viewContractExpectResult
        "required view is not known"
        (checkTypedProgramWith policyStrict listMapWrongOutputContract))
      (viewContractExpectResult
        "function argument view is not known"
        (checkTypedProgramWith policyStrict listFilterWrongPredicateContract))
      (viewContractExpectResult
        "function argument view is not known"
        (checkTypedProgramWith policyStrict listMapWrongListArgExprContract))
      (viewContractExpectErrorTag
        errorTagOk
        (checkTypedProgram listMapBoolStringContract))
      (viewContractExpectErrorTag
        errorTagMissingFunctionArgumentView
        (checkTypedProgramWith policyStrict listMapWrongFunctionArgContract))
      (viewContractExpectErrorTag
        errorTagMissingFunctionArgumentView
        (checkTypedProgramWith policyStrict listMapWrongListArgContract))
      (viewContractExpectErrorTag
        errorTagMissingFunctionArgumentView
        (checkTypedProgramWith policyStrict listMapWrongListArgExprContract))
      (viewContractExpectErrorTag
        errorTagMissingRequiredView
        (checkTypedProgramWith policyStrict listMapWrongOutputContract))
      (viewContractExpectDiagnostic
        errorTagMissingFunctionArgumentView
        162
        (viewList viewBool)
        (checkTypedProgramWith policyStrict listMapWrongListArgContract))
      (viewContractExpectDiagnostic
        errorTagMissingRequiredView
        174
        (viewList viewBool)
        (checkTypedProgramWith policyStrict listMapWrongOutputContract))
      (viewContractExpectDiagnosticActual
        errorTagMissingFunctionArgumentView
        162
        (viewList viewBool)
        (viewList viewString)
        (checkTypedProgramWith policyStrict listMapWrongListArgContract))
      (viewContractExpectDiagnosticActual
        errorTagMissingFunctionArgumentView
        193
        (viewList viewBool)
        (viewList viewString)
        (checkTypedProgramWith policyStrict listMapWrongListArgExprContract))
      (viewContractExpectDiagnosticActual
        errorTagMissingRequiredView
        174
        (viewList viewBool)
        (viewList viewString)
        (checkTypedProgramWith policyStrict listMapWrongOutputContract))
      (viewContractExpectDiagnosticActual
        errorTagMissingFunctionArgumentView
        181
        (viewFn [(viewBool)] viewBool)
        (viewFn [(viewBool)] viewString)
        (checkTypedProgramWith policyStrict listFilterWrongPredicateContract))
      (matchResult
        (diag env :
          viewContractProbe
            (equal?
              (renderDiagnostic diag)
              "symbol 162 expected List Bool but got List String"))
        (env rest : "fail")
        (checkTypedProgramWith policyStrict listMapWrongListArgContract))]