Lexical.hs

-- Note: this is an automatically generated file. Do not edit.

-- | A module for lexical operations over graphs.

module Hydra.Lexical where

import qualified Hydra.Ast as Ast
import qualified Hydra.Coders as Coders
import qualified Hydra.Core as Core
import qualified Hydra.Docs as Docs
import qualified Hydra.Error.Checking as Checking
import qualified Hydra.Error.Core as ErrorCore
import qualified Hydra.Error.File as ErrorFile
import qualified Hydra.Error.Packaging as ErrorPackaging
import qualified Hydra.Error.System as ErrorSystem
import qualified Hydra.Errors as Errors
import qualified Hydra.File as File
import qualified Hydra.Graph as Graph
import qualified Hydra.Json.Model as Model
import qualified Hydra.Overlay.Haskell.Lib.Eithers as Eithers
import qualified Hydra.Overlay.Haskell.Lib.Equality as Equality
import qualified Hydra.Overlay.Haskell.Lib.Lists as Lists
import qualified Hydra.Overlay.Haskell.Lib.Literals as Literals
import qualified Hydra.Overlay.Haskell.Lib.Logic as Logic
import qualified Hydra.Overlay.Haskell.Lib.Maps as Maps
import qualified Hydra.Overlay.Haskell.Lib.Math as Math
import qualified Hydra.Overlay.Haskell.Lib.Optionals as Optionals
import qualified Hydra.Overlay.Haskell.Lib.Pairs as Pairs
import qualified Hydra.Overlay.Haskell.Lib.Sets as Sets
import qualified Hydra.Overlay.Haskell.Lib.Strings as Strings
import qualified Hydra.Packaging as Packaging
import qualified Hydra.Parsing as Parsing
import qualified Hydra.Paths as Paths
import qualified Hydra.Query as Query
import qualified Hydra.Relational as Relational
import qualified Hydra.Scoping as Scoping
import qualified Hydra.Show.Core as ShowCore
import qualified Hydra.Show.Errors as ShowErrors
import qualified Hydra.Strip as Strip
import qualified Hydra.System as System
import qualified Hydra.Tabular as Tabular
import qualified Hydra.Testing as Testing
import qualified Hydra.Time as Time
import qualified Hydra.Topology as Topology
import qualified Hydra.Typed as Typed
import qualified Hydra.Typing as Typing
import qualified Hydra.Util as Util
import qualified Hydra.Validation as Validation
import qualified Hydra.Variants as Variants
import Prelude hiding  (Enum, Ordering, decodeFloat, encodeFloat, fail, map, pure, sum)
import qualified Data.Scientific as Sci
import qualified Data.Map as M
import qualified Data.Set as S

-- | Build a Graph from element bindings, environment, and primitives
buildGraph :: [Core.Binding] -> M.Map Core.Name (Maybe Core.Term) -> M.Map Core.Name Graph.Primitive -> Graph.Graph
buildGraph elements environment primitives =

      let elementTerms = Maps.fromList (Lists.map (\b -> (Core.bindingName b, (Core.bindingTerm b))) elements)
          letTerms =
                  Maps.fromList (Optionals.mapOptional (\kv -> Optionals.map (\t -> (Pairs.first kv, t)) (Pairs.second kv)) (Maps.toList environment))
          mergedTerms = Maps.union elementTerms letTerms
          filteredTerms = Maps.filterWithKey (\k -> \_v -> Logic.not (Maps.member k primitives)) mergedTerms
          elementTypes =
                  Maps.fromList (Optionals.cat (Lists.map (\b -> Optionals.map (\ts -> (Core.bindingName b, ts)) (Core.bindingTypeScheme b)) elements))
          filteredTypes = Maps.filterWithKey (\k -> \_v -> Logic.not (Maps.member k primitives)) elementTypes
      in Graph.Graph {
        Graph.graphBoundTerms = filteredTerms,
        Graph.graphBoundTypes = filteredTypes,
        Graph.graphClassConstraints = Maps.empty,
        Graph.graphLambdaVariables = (Sets.fromList (Maps.keys (Maps.filter (\mt -> Optionals.isNone mt) environment))),
        Graph.graphMetadata = Maps.empty,
        Graph.graphPrimitives = primitives,
        Graph.graphSchemaTypes = Maps.empty,
        Graph.graphTypeVariables = Sets.empty}

-- | Pick a name that does not collide with a reserved set, by appending a numeric suffix to the requested name when necessary
chooseUniqueName :: S.Set Core.Name -> Core.Name -> Core.Name
chooseUniqueName reserved name =

      let tryName =
              \index ->
                let candidate = Logic.ifElse (Equality.equal index 1) name (Core.Name (Strings.cat2 (Core.unName name) (Literals.showInt32 index)))
                in (Logic.ifElse (Sets.member candidate reserved) (tryName (Math.add index 1)) candidate)
      in (tryName 1)

-- | Resolve a schema type through a chain of zero or more typedefs
dereferenceSchemaType :: Core.Name -> M.Map Core.Name Core.TypeScheme -> Maybe Core.TypeScheme
dereferenceSchemaType name types =

      let forType =
              \t -> case t of
                Core.TypeAnnotated v0 -> forType (Core.annotatedTypeBody v0)
                Core.TypeForall v0 -> Optionals.map (\ts -> Core.TypeScheme {
                  Core.typeSchemeVariables = (Lists.cons (Core.forallTypeParameter v0) (Core.typeSchemeVariables ts)),
                  Core.typeSchemeBody = (Core.typeSchemeBody ts),
                  Core.typeSchemeConstraints = (Core.typeSchemeConstraints ts)}) (forType (Core.forallTypeBody v0))
                Core.TypeVariable v0 -> dereferenceSchemaType v0 types
                _ -> Just (Core.TypeScheme {
                  Core.typeSchemeVariables = [],
                  Core.typeSchemeBody = t,
                  Core.typeSchemeConstraints = Nothing})
      in (Optionals.bind (Maps.lookup name types) (\ts -> Optionals.map (\ts2 -> Core.TypeScheme {
        Core.typeSchemeVariables = (Lists.concat2 (Core.typeSchemeVariables ts) (Core.typeSchemeVariables ts2)),
        Core.typeSchemeBody = (Core.typeSchemeBody ts2),
        Core.typeSchemeConstraints = (Core.typeSchemeConstraints ts2)}) (forType (Core.typeSchemeBody ts))))

-- | Look up a binding by name in a graph, returning Either an error or the binding
dereferenceVariable :: Graph.Graph -> Core.Name -> Either Errors.Error Core.Binding
dereferenceVariable graph name =
    Optionals.cases (lookupBinding graph name) (Left (Errors.ErrorResolution (Errors.ResolutionErrorNoSuchBinding (Errors.NoSuchBindingError {
      Errors.noSuchBindingErrorName = name})))) (\right_ -> Right right_)

-- | Create a graph from a parent graph, schema types, and list of element bindings
elementsToGraph :: Graph.Graph -> M.Map Core.Name Core.TypeScheme -> [Core.Binding] -> Graph.Graph
elementsToGraph parent schemaTypes elements =

      let prims = Graph.graphPrimitives parent
          g = buildGraph elements Maps.empty prims
      in Graph.Graph {
        Graph.graphBoundTerms = (Graph.graphBoundTerms g),
        Graph.graphBoundTypes = (Graph.graphBoundTypes g),
        Graph.graphClassConstraints = (Graph.graphClassConstraints g),
        Graph.graphLambdaVariables = (Graph.graphLambdaVariables g),
        Graph.graphMetadata = (Graph.graphMetadata g),
        Graph.graphPrimitives = (Graph.graphPrimitives g),
        Graph.graphSchemaTypes = schemaTypes,
        Graph.graphTypeVariables = (Graph.graphTypeVariables g)}

-- | An empty graph; no elements, no primitives, no schema.
emptyGraph :: Graph.Graph
emptyGraph =
    Graph.Graph {
      Graph.graphBoundTerms = Maps.empty,
      Graph.graphBoundTypes = Maps.empty,
      Graph.graphClassConstraints = Maps.empty,
      Graph.graphLambdaVariables = Sets.empty,
      Graph.graphMetadata = Maps.empty,
      Graph.graphPrimitives = Maps.empty,
      Graph.graphSchemaTypes = Maps.empty,
      Graph.graphTypeVariables = Sets.empty}

-- | An empty inference context; fresh-variable counter at zero and empty trace.
emptyInferenceContext :: Typing.InferenceContext
emptyInferenceContext =
    Typing.InferenceContext {
      Typing.inferenceContextFreshTypeVariableCount = 0,
      Typing.inferenceContextTrace = []}

-- | Extract the fields of a record or union type
fieldsOf :: Core.Type -> [Core.FieldType]
fieldsOf t =

      let stripped = Strip.deannotateType t
      in case stripped of
        Core.TypeForall v0 -> fieldsOf (Core.forallTypeBody v0)
        Core.TypeRecord v0 -> v0
        Core.TypeUnion v0 -> v0
        _ -> []

-- | Look up a field by name in a record's field map and decode its value, failing if the field is missing
getField :: M.Map Core.Name t0 -> Core.Name -> (t0 -> Either Errors.Error t1) -> Either Errors.Error t1
getField m fname decode =
    Optionals.cases (Maps.lookup fname m) (Left (Errors.ErrorResolution (Errors.ResolutionErrorNoMatchingField (Errors.NoMatchingFieldError {
      Errors.noMatchingFieldErrorFieldName = fname})))) decode

-- | Reconstruct a list of Bindings from a Graph's boundTerms and boundTypes
graphToBindings :: Graph.Graph -> [Core.Binding]
graphToBindings g =
    Lists.map (\p ->
      let name = Pairs.first p
          term = Pairs.second p
      in Core.Binding {
        Core.bindingName = name,
        Core.bindingTerm = term,
        Core.bindingTypeScheme = (Maps.lookup name (Graph.graphBoundTypes g))}) (Maps.toList (Graph.graphBoundTerms g))

-- | Build a graph with primitives assembled from built-in and user-provided lists. User-provided primitives shadow built-in ones.
graphWithPrimitives :: [Graph.Primitive] -> [Graph.Primitive] -> Graph.Graph
graphWithPrimitives builtIn userProvided =

      let toMap = \ps -> Maps.fromList (Lists.map (\p -> (Packaging.primitiveDefinitionName (Graph.primitiveDefinition p), p)) ps)
          prims = Maps.union (toMap userProvided) (toMap builtIn)
      in (buildGraph [] Maps.empty prims)

-- | Look up a binding in a graph by name
lookupBinding :: Graph.Graph -> Core.Name -> Maybe Core.Binding
lookupBinding graph name =
    Optionals.map (\term -> Core.Binding {
      Core.bindingName = name,
      Core.bindingTerm = term,
      Core.bindingTypeScheme = (Maps.lookup name (Graph.graphBoundTypes graph))}) (Maps.lookup name (Graph.graphBoundTerms graph))

-- | Look up a primitive function in a graph by name
lookupPrimitive :: Graph.Graph -> Core.Name -> Maybe Graph.Primitive
lookupPrimitive graph name = Maps.lookup name (Graph.graphPrimitives graph)

-- | Look up a term by name in a graph
lookupTerm :: Graph.Graph -> Core.Name -> Maybe Core.Term
lookupTerm graph name = Maps.lookup name (Graph.graphBoundTerms graph)

-- | Match a term against an enum type, dispatching on the variant name to a value from the supplied list
matchEnum :: Graph.Graph -> Core.Name -> [(Core.Name, t0)] -> Core.Term -> Either Errors.Error t0
matchEnum graph tname pairs =
    matchUnion graph tname (Lists.map (\pair -> matchUnitField (Pairs.first pair) (Pairs.second pair)) pairs)

-- | Match a term against a record type and decode its fields, failing if the term is not a record
matchRecord :: t0 -> (M.Map Core.Name Core.Term -> Either Errors.Error t1) -> Core.Term -> Either Errors.Error t1
matchRecord graph decode term =

      let stripped = Strip.deannotateAndDetypeTerm term
      in case stripped of
        Core.TermRecord v0 -> decode (Maps.fromList (Lists.map (\field -> (Core.fieldName field, (Core.fieldTerm field))) (Core.recordFields v0)))
        _ -> Left (Errors.ErrorResolution (Errors.ResolutionErrorUnexpectedShape (Errors.UnexpectedShapeError {
          Errors.unexpectedShapeErrorExpected = "record",
          Errors.unexpectedShapeErrorActual = (ShowCore.term term)})))

-- | Match a term against a union type, dispatching on the injected variant to the appropriate decoder. Variable terms are dereferenced through the graph before matching.
matchUnion :: Graph.Graph -> Core.Name -> [(Core.Name, (Core.Term -> Either Errors.Error t0))] -> Core.Term -> Either Errors.Error t0
matchUnion graph tname pairs term =

      let stripped = Strip.deannotateAndDetypeTerm term
          mapping = Maps.fromList pairs
      in case stripped of
        Core.TermVariable v0 -> Eithers.bind (requireBinding graph v0) (\el -> matchUnion graph tname pairs (Core.bindingTerm el))
        Core.TermInject v0 ->
          let exp =

                    let fname = Core.fieldName (Core.injectionField v0)
                        val = Core.fieldTerm (Core.injectionField v0)
                    in (Optionals.cases (Maps.lookup fname mapping) (Left (Errors.ErrorResolution (Errors.ResolutionErrorNoMatchingField (Errors.NoMatchingFieldError {
                      Errors.noMatchingFieldErrorFieldName = fname})))) (\f -> f val))
          in (Logic.ifElse (Equality.equal (Core.unName (Core.injectionTypeName v0)) (Core.unName tname)) exp (Left (Errors.ErrorResolution (Errors.ResolutionErrorUnexpectedShape (Errors.UnexpectedShapeError {
            Errors.unexpectedShapeErrorExpected = (Strings.cat2 "injection for type " (Core.unName tname)),
            Errors.unexpectedShapeErrorActual = (ShowCore.term term)})))))
        _ -> Left (Errors.ErrorResolution (Errors.ResolutionErrorUnexpectedShape (Errors.UnexpectedShapeError {
          Errors.unexpectedShapeErrorExpected = (Strings.cat2 "injection for type " (Core.unName tname)),
          Errors.unexpectedShapeErrorActual = (ShowCore.term stripped)})))

-- | Build a (fieldName, decoder) pair for a unit-valued union variant: the decoder ignores its argument and returns a fixed value
matchUnitField :: t0 -> t1 -> (t0, (t2 -> Either t3 t1))
matchUnitField fname x = (fname, (\ignored -> Right x))

-- | Look up a binding in a graph by name, failing with a list of available names if it is not found
requireBinding :: Graph.Graph -> Core.Name -> Either Errors.Error Core.Binding
requireBinding graph name =

      let showAll = False
          ellipsis =
                  \strings -> Logic.ifElse (Logic.and (Equality.gt (Lists.length strings) 3) (Logic.not showAll)) (Lists.concat2 (Lists.take 3 strings) [
                    "..."]) strings
          errMsg =
                  Strings.cat2 (Strings.cat2 (Strings.cat2 (Strings.cat2 "no such element: " (Core.unName name)) ". Available elements: {") (Strings.intercalate ", " (ellipsis (Lists.map Core.unName (Maps.keys (Graph.graphBoundTerms graph)))))) "}"
      in (Optionals.cases (lookupBinding graph name) (Left (Errors.ErrorResolution (Errors.ResolutionErrorOther (Errors.OtherResolutionError errMsg)))) (\x -> Right x))

-- | Look up a primitive in a graph by name, failing if it is not registered
requirePrimitive :: Graph.Graph -> Core.Name -> Either Errors.Error Graph.Primitive
requirePrimitive graph name =
    Optionals.cases (lookupPrimitive graph name) (Left (Errors.ErrorResolution (Errors.ResolutionErrorNoSuchPrimitive (Errors.NoSuchPrimitiveError {
      Errors.noSuchPrimitiveErrorName = name})))) (\x -> Right x)

-- | Look up a primitive's type scheme in a graph by name, failing if the primitive is not registered
requirePrimitiveType :: Graph.Graph -> Core.Name -> Either Errors.Error Core.TypeScheme
requirePrimitiveType tx name =

      let mts =
              Optionals.map (\_p -> Scoping.termSignatureToTypeScheme (Packaging.primitiveDefinitionSignature (Graph.primitiveDefinition _p))) (Maps.lookup name (Graph.graphPrimitives tx))
      in (Optionals.cases mts (Left (Errors.ErrorResolution (Errors.ResolutionErrorNoSuchPrimitive (Errors.NoSuchPrimitiveError {
        Errors.noSuchPrimitiveErrorName = name})))) (\ts -> Right ts))

-- | Resolve a name to a term in the graph, following variable references, and fail if the name is not bound
requireTerm :: Graph.Graph -> Core.Name -> Either Errors.Error Core.Term
requireTerm graph name =
    Optionals.cases (resolveTerm graph name) (Left (Errors.ErrorResolution (Errors.ResolutionErrorNoSuchBinding (Errors.NoSuchBindingError {
      Errors.noSuchBindingErrorName = name})))) (\x -> Right x)

-- | TODO: distinguish between lambda-bound and let-bound variables
resolveTerm :: Graph.Graph -> Core.Name -> Maybe Core.Term
resolveTerm graph name =

      let recurse =
              \term ->
                let stripped = Strip.deannotateTerm term
                in case stripped of
                  Core.TermVariable v0 -> resolveTerm graph v0
                  _ -> Just term
      in (Optionals.cases (lookupTerm graph name) Nothing recurse)

-- | Strip annotations and type lambdas/applications from a term, then follow variable references through the graph until a non-variable term is reached
stripAndDereferenceTerm :: Graph.Graph -> Core.Term -> Either Errors.Error Core.Term
stripAndDereferenceTerm graph term =

      let stripped = Strip.deannotateAndDetypeTerm term
      in case stripped of
        Core.TermVariable v0 -> Eithers.bind (requireTerm graph v0) (\t -> stripAndDereferenceTerm graph t)
        _ -> Right stripped

-- | Strip annotations and dereference variables, returning Either an error or the resolved term
stripAndDereferenceTermEither :: Graph.Graph -> Core.Term -> Either Errors.Error Core.Term
stripAndDereferenceTermEither graph term =

      let stripped = Strip.deannotateAndDetypeTerm term
      in case stripped of
        Core.TermVariable v0 -> Eithers.either (\left_ -> Left left_) (\binding -> stripAndDereferenceTermEither graph (Core.bindingTerm binding)) (dereferenceVariable graph v0)
        _ -> Right stripped