content: -- | Simple, one-way adapters for types and terms
  
  module Hydra.Adapt.Simple where
  
  import qualified Hydra.Coders as Coders
  import qualified Hydra.Compute as Compute
  import qualified Hydra.Core as Core
  import qualified Hydra.Graph as Graph
  import qualified Hydra.Inference as Inference
  import qualified Hydra.Lib.Equality as Equality
  import qualified Hydra.Lib.Flows as Flows
  import qualified Hydra.Lib.Lists as Lists
  import qualified Hydra.Lib.Literals as Literals
  import qualified Hydra.Lib.Logic as Logic
  import qualified Hydra.Lib.Maps as Maps
  import qualified Hydra.Lib.Optionals as Optionals
  import qualified Hydra.Lib.Sets as Sets
  import qualified Hydra.Lib.Strings as Strings
  import qualified Hydra.Literals as Literals_
  import qualified Hydra.Module as Module
  import qualified Hydra.Reduction as Reduction
  import qualified Hydra.Rewriting as Rewriting
  import qualified Hydra.Schemas as Schemas
  import qualified Hydra.Show.Core as Core_
  import qualified Hydra.Variants as Variants
  import Prelude hiding  (Enum, Ordering, fail, map, pure, sum)
  import qualified Data.Int as I
  import qualified Data.List as L
  import qualified Data.Map as M
  import qualified Data.Set as S
  
  -- | Attempt to adapt a floating-point type using the given language constraints
  adaptFloatType :: (Coders.LanguageConstraints -> Core.FloatType -> Maybe Core.FloatType)
  adaptFloatType constraints ft =  
    let supported = (Sets.member ft (Coders.languageConstraintsFloatTypes constraints))
    in  
      let alt = (adaptFloatType constraints)
      in (Logic.ifElse supported (Just ft) ((\x -> case x of
        Core.FloatTypeBigfloat -> Nothing
        Core.FloatTypeFloat32 -> (alt Core.FloatTypeFloat64)
        Core.FloatTypeFloat64 -> (alt Core.FloatTypeBigfloat)) ft))
  
  -- | Adapt a graph and its schema to the given language constraints, prior to inference
  adaptDataGraph :: (Coders.LanguageConstraints -> Bool -> Graph.Graph -> Compute.Flow Graph.Graph Graph.Graph)
  adaptDataGraph constraints doExpand graph0 =  
    let litmap = (adaptLiteralTypesMap constraints)
    in  
      let els0 = (Graph.graphElements graph0)
      in  
        let env0 = (Graph.graphEnvironment graph0)
        in  
          let body0 = (Graph.graphBody graph0)
          in  
            let prims0 = (Graph.graphPrimitives graph0)
            in  
              let schema0 = (Graph.graphSchema graph0)
              in (Flows.bind (Optionals.maybe (Flows.pure Nothing) (\sg -> Flows.bind (Schemas.graphAsTypes sg) (\tmap0 -> Flows.bind (adaptGraphSchema constraints litmap tmap0) (\tmap1 ->  
                let emap = (Schemas.typesToElements tmap1)
                in (Flows.pure (Just (Graph.Graph {
                  Graph.graphElements = emap,
                  Graph.graphEnvironment = (Graph.graphEnvironment sg),
                  Graph.graphTypes = (Graph.graphTypes sg),
                  Graph.graphBody = (Graph.graphBody sg),
                  Graph.graphPrimitives = (Graph.graphPrimitives sg),
                  Graph.graphSchema = (Graph.graphSchema sg)})))))) schema0) (\schema1 ->  
                let gterm0 = (Schemas.graphAsTerm graph0)
                in  
                  let gterm1 = (Logic.ifElse doExpand (Rewriting.unshadowVariables (Reduction.etaExpandTerm graph0 gterm0)) gterm0)
                  in (Flows.bind (adaptTerm constraints litmap gterm1) (\gterm2 ->  
                    let els1 = (Schemas.termAsGraph gterm2)
                    in (Flows.bind (Flows.mapElems (adaptPrimitive constraints litmap) prims0) (\prims1 -> Flows.pure (Graph.Graph {
                      Graph.graphElements = els1,
                      Graph.graphEnvironment = env0,
                      Graph.graphTypes = Maps.empty,
                      Graph.graphBody = Core.TermUnit,
                      Graph.graphPrimitives = prims1,
                      Graph.graphSchema = schema1})))))))
  
  adaptGraphSchema :: (Ord t0) => (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> M.Map t0 Core.Type -> Compute.Flow t1 (M.Map t0 Core.Type))
  adaptGraphSchema constraints litmap types0 =  
    let mapPair = (\pair ->  
            let name = (fst pair)
            in  
              let typ = (snd pair)
              in (Flows.bind (adaptType constraints litmap typ) (\typ1 -> Flows.pure (name, typ1))))
    in (Flows.bind (Flows.mapList mapPair (Maps.toList types0)) (\pairs -> Flows.pure (Maps.fromList pairs)))
  
  -- | Attempt to adapt an integer type using the given language constraints
  adaptIntegerType :: (Coders.LanguageConstraints -> Core.IntegerType -> Maybe Core.IntegerType)
  adaptIntegerType constraints it =  
    let supported = (Sets.member it (Coders.languageConstraintsIntegerTypes constraints))
    in  
      let alt = (adaptIntegerType constraints)
      in (Logic.ifElse supported (Just it) ((\x -> case x of
        Core.IntegerTypeBigint -> Nothing
        Core.IntegerTypeInt8 -> (alt Core.IntegerTypeUint16)
        Core.IntegerTypeInt16 -> (alt Core.IntegerTypeUint32)
        Core.IntegerTypeInt32 -> (alt Core.IntegerTypeUint64)
        Core.IntegerTypeInt64 -> (alt Core.IntegerTypeBigint)
        Core.IntegerTypeUint8 -> (alt Core.IntegerTypeInt16)
        Core.IntegerTypeUint16 -> (alt Core.IntegerTypeInt32)
        Core.IntegerTypeUint32 -> (alt Core.IntegerTypeInt64)
        Core.IntegerTypeUint64 -> (alt Core.IntegerTypeBigint)) it))
  
  -- | Convert a literal to a different type
  adaptLiteral :: (Core.LiteralType -> Core.Literal -> Core.Literal)
  adaptLiteral lt l = ((\x -> case x of
    Core.LiteralBinary v1 -> ((\x -> case x of
      Core.LiteralTypeString -> (Core.LiteralString (Literals.binaryToString v1))) lt)
    Core.LiteralBoolean v1 -> ((\x -> case x of
      Core.LiteralTypeInteger v2 -> (Core.LiteralInteger (Literals_.bigintToIntegerValue v2 (Logic.ifElse v1 1 0)))) lt)
    Core.LiteralFloat v1 -> ((\x -> case x of
      Core.LiteralTypeFloat v2 -> (Core.LiteralFloat (Literals_.bigfloatToFloatValue v2 (Literals_.floatValueToBigfloat v1)))) lt)
    Core.LiteralInteger v1 -> ((\x -> case x of
      Core.LiteralTypeInteger v2 -> (Core.LiteralInteger (Literals_.bigintToIntegerValue v2 (Literals_.integerValueToBigint v1)))) lt)) l)
  
  -- | Attempt to adapt a literal type using the given language constraints
  adaptLiteralType :: (Coders.LanguageConstraints -> Core.LiteralType -> Maybe Core.LiteralType)
  adaptLiteralType constraints lt = (Logic.ifElse (literalTypeSupported constraints lt) Nothing ((\x -> case x of
    Core.LiteralTypeBinary -> (Just Core.LiteralTypeString)
    Core.LiteralTypeBoolean -> (Optionals.map (\x -> Core.LiteralTypeInteger x) (adaptIntegerType constraints Core.IntegerTypeInt8))
    Core.LiteralTypeFloat v1 -> (Optionals.map (\x -> Core.LiteralTypeFloat x) (adaptFloatType constraints v1))
    Core.LiteralTypeInteger v1 -> (Optionals.map (\x -> Core.LiteralTypeInteger x) (adaptIntegerType constraints v1))
    _ -> Nothing) lt))
  
  -- | Derive a map of adapted literal types for the given language constraints
  adaptLiteralTypesMap :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType)
  adaptLiteralTypesMap constraints =  
    let tryType = (\lt -> Optionals.maybe Nothing (\lt2 -> Just (lt, lt2)) (adaptLiteralType constraints lt))
    in (Maps.fromList (Optionals.cat (Lists.map tryType Variants.literalTypes)))
  
  adaptLiteralValue :: (Ord t0) => (M.Map t0 Core.LiteralType -> t0 -> Core.Literal -> Core.Literal)
  adaptLiteralValue litmap lt l = (Optionals.maybe (Core.LiteralString (Core_.literal l)) (\lt2 -> adaptLiteral lt2 l) (Maps.lookup lt litmap))
  
  adaptPrimitive :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Graph.Primitive -> Compute.Flow t0 Graph.Primitive)
  adaptPrimitive constraints litmap prim0 =  
    let ts0 = (Graph.primitiveType prim0)
    in (Flows.bind (adaptTypeScheme constraints litmap ts0) (\ts1 -> Flows.pure (Graph.Primitive {
      Graph.primitiveName = (Graph.primitiveName prim0),
      Graph.primitiveType = ts1,
      Graph.primitiveImplementation = (Graph.primitiveImplementation prim0)})))
  
  -- | Adapt a term using the given language constraints
  adaptTerm :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Core.Term -> Compute.Flow Graph.Graph Core.Term)
  adaptTerm constraints litmap term0 =  
    let rewrite = (\recurse -> \term0 -> Flows.bind (recurse term0) (\term1 ->  
            let tryTerm = (\term ->  
                    let supportedVariant = (Sets.member (Variants.termVariant term) (Coders.languageConstraintsTermVariants constraints))
                    in (Logic.ifElse supportedVariant ((\x -> case x of
                      Core.TermLiteral v1 ->  
                        let lt = (Variants.literalType v1)
                        in (Flows.pure (Just (Logic.ifElse (literalTypeSupported constraints lt) term (Core.TermLiteral (adaptLiteralValue litmap lt v1)))))
                      _ -> (Flows.pure (Just term))) term) ( 
                      let tryAlts = (\alts -> Logic.ifElse (Lists.null alts) (Flows.pure Nothing) (Flows.bind (tryTerm (Lists.head alts)) (\mterm -> Optionals.maybe (tryAlts (Lists.tail alts)) (\t -> Flows.pure (Just t)) mterm)))
                      in (Flows.bind (termAlternatives term1) (\alts -> tryAlts alts)))))
            in (Flows.bind (tryTerm term1) (\mterm -> Optionals.maybe (Flows.fail (Strings.cat [
              "no alternatives for term: ",
              (Core_.term term1)])) (\term2 -> Flows.pure term2) mterm))))
    in (Rewriting.rewriteTermM rewrite term0)
  
  adaptType :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Core.Type -> Compute.Flow t0 Core.Type)
  adaptType constraints litmap type0 =  
    let rewrite = (\recurse -> \typ -> Flows.bind (recurse typ) (\type1 ->  
            let tryType = (\typ ->  
                    let supportedVariant = (Sets.member (Variants.typeVariant typ) (Coders.languageConstraintsTypeVariants constraints))
                    in (Logic.ifElse supportedVariant ((\x -> case x of
                      Core.TypeLiteral v1 -> (Logic.ifElse (literalTypeSupported constraints v1) (Just typ) (Optionals.maybe (Just (Core.TypeLiteral Core.LiteralTypeString)) (\lt2 -> Just (Core.TypeLiteral lt2)) (Maps.lookup v1 litmap)))
                      _ -> (Just typ)) typ) ( 
                      let tryAlts = (\alts -> Logic.ifElse (Lists.null alts) Nothing (Optionals.maybe (tryAlts (Lists.tail alts)) (\t -> Just t) (tryType (Lists.head alts))))
                      in  
                        let alts = (typeAlternatives type1)
                        in (tryAlts alts))))
            in (Optionals.maybe (Flows.fail (Strings.cat [
              "no alternatives for type: ",
              (Core_.type_ typ)])) (\type2 -> Flows.pure type2) (tryType type1))))
    in (Rewriting.rewriteTypeM rewrite type0)
  
  adaptTypeScheme :: (Coders.LanguageConstraints -> M.Map Core.LiteralType Core.LiteralType -> Core.TypeScheme -> Compute.Flow t0 Core.TypeScheme)
  adaptTypeScheme constraints litmap ts0 =  
    let vars0 = (Core.typeSchemeVariables ts0)
    in  
      let t0 = (Core.typeSchemeType ts0)
      in (Flows.bind (adaptType constraints litmap t0) (\t1 -> Flows.pure (Core.TypeScheme {
        Core.typeSchemeVariables = vars0,
        Core.typeSchemeType = t1})))
  
  -- | Given a data graph along with language constraints and a designated list of element names, adapt the graph to the language constraints, perform inference, then return a corresponding term definition for each element name.
  dataGraphToDefinitions :: (Coders.LanguageConstraints -> Bool -> Graph.Graph -> [[Core.Name]] -> Compute.Flow Graph.Graph (Graph.Graph, [[Module.TermDefinition]]))
  dataGraphToDefinitions constraints doExpand graph nameLists = (Flows.bind (Logic.ifElse doExpand (Inference.inferGraphTypes graph) (Flows.pure graph)) (\graphi -> Flows.bind (adaptDataGraph constraints doExpand graphi) (\graph1 -> Flows.bind (Inference.inferGraphTypes graph1) (\graph2 ->  
    let toDef = (\el ->  
            let ts = (Optionals.fromJust (Core.bindingType el))
            in Module.TermDefinition {
              Module.termDefinitionName = (Core.bindingName el),
              Module.termDefinitionTerm = (Core.bindingTerm el),
              Module.termDefinitionType = (Schemas.typeSchemeToFType ts)})
    in (Flows.pure (graph2, (Lists.map (\names -> Lists.map toDef (Lists.map (\n -> Optionals.fromJust (Maps.lookup n (Graph.graphElements graph2))) names)) nameLists)))))))
  
  -- | Check if a literal type is supported by the given language constraints
  literalTypeSupported :: (Coders.LanguageConstraints -> Core.LiteralType -> Bool)
  literalTypeSupported constraints lt = (Logic.ifElse (Sets.member (Variants.literalTypeVariant lt) (Coders.languageConstraintsLiteralVariants constraints)) ((\x -> case x of
    Core.LiteralTypeFloat v1 -> (Sets.member v1 (Coders.languageConstraintsFloatTypes constraints))
    Core.LiteralTypeInteger v1 -> (Sets.member v1 (Coders.languageConstraintsIntegerTypes constraints))
    _ -> True) lt) False)
  
  -- | Given a schema graph along with language constraints and a designated list of element names, adapt the graph to the language constraints, then return a corresponding type definition for each element name.
  schemaGraphToDefinitions :: (Coders.LanguageConstraints -> Graph.Graph -> [[Core.Name]] -> Compute.Flow Graph.Graph (M.Map Core.Name Core.Type, [[Module.TypeDefinition]]))
  schemaGraphToDefinitions constraints graph nameLists =  
    let litmap = (adaptLiteralTypesMap constraints)
    in (Flows.bind (Schemas.graphAsTypes graph) (\tmap0 -> Flows.bind (adaptGraphSchema constraints litmap tmap0) (\tmap1 ->  
      let toDef = (\pair -> Module.TypeDefinition {
              Module.typeDefinitionName = (fst pair),
              Module.typeDefinitionType = (snd pair)})
      in (Flows.pure (tmap1, (Lists.map (\names -> Lists.map toDef (Lists.map (\n -> (n, (Optionals.fromJust (Maps.lookup n tmap1)))) names)) nameLists))))))
  
  -- | Find a list of alternatives for a given term, if any
  termAlternatives :: (Core.Term -> Compute.Flow Graph.Graph [Core.Term])
  termAlternatives term = ((\x -> case x of
    Core.TermAnnotated v1 ->  
      let term2 = (Core.annotatedTermSubject v1)
      in (Flows.pure [
        term2])
    Core.TermOptional v1 -> (Flows.pure [
      Core.TermList (Optionals.maybe [] (\term2 -> [
        term2]) v1)])
    Core.TermUnion v1 ->  
      let tname = (Core.injectionTypeName v1)
      in  
        let field = (Core.injectionField v1)
        in  
          let fname = (Core.fieldName field)
          in  
            let fterm = (Core.fieldTerm field)
            in (Flows.bind (Schemas.requireUnionType tname) (\rt -> Flows.pure [
               
                let forFieldType = (\ft ->  
                        let ftname = (Core.fieldTypeName ft)
                        in Core.Field {
                          Core.fieldName = fname,
                          Core.fieldTerm = (Core.TermOptional (Logic.ifElse (Equality.equal ftname fname) (Just fterm) Nothing))})
                in  
                  let fields = (Lists.map forFieldType (Core.rowTypeFields rt))
                  in (Core.TermRecord (Core.Record {
                    Core.recordTypeName = tname,
                    Core.recordFields = fields}))]))
    Core.TermUnit -> (Flows.pure [
      Core.TermLiteral (Core.LiteralBoolean True)])
    Core.TermWrap v1 ->  
      let term2 = (Core.wrappedTermObject v1)
      in (Flows.pure [
        term2])
    _ -> (Flows.pure [])) term)
  
  -- | Find a list of alternatives for a given type, if any
  typeAlternatives :: (Core.Type -> [Core.Type])
  typeAlternatives type_ = ((\x -> case x of
    Core.TypeAnnotated v1 ->  
      let type2 = (Core.annotatedTypeSubject v1)
      in [
        type2]
    Core.TypeOptional v1 -> [
      Core.TypeList v1]
    Core.TypeUnion v1 ->  
      let tname = (Core.rowTypeTypeName v1)
      in  
        let fields = (Core.rowTypeFields v1)
        in [
          Core.TypeRecord (Core.RowType {
            Core.rowTypeTypeName = tname,
            Core.rowTypeFields = fields})]
    Core.TypeUnit -> [
      Core.TypeLiteral Core.LiteralTypeBoolean]
    _ -> []) type_)
  