Coder.hs

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

-- | Lisp code generator: converts Hydra type and term modules to Lisp AST

module Hydra.Lisp.Coder where

import qualified Hydra.Analysis as Analysis
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.Environment as Environment
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.Formatting as Formatting
import qualified Hydra.Graph as Graph
import qualified Hydra.Json.Model as Model
import qualified Hydra.Lexical as Lexical
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.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.Lisp.Language as Language
import qualified Hydra.Lisp.Syntax as Syntax
import qualified Hydra.Names as Names
import qualified Hydra.Packaging as Packaging
import qualified Hydra.Parsing as Parsing
import qualified Hydra.Paths as Paths
import qualified Hydra.Predicates as Predicates
import qualified Hydra.Query as Query
import qualified Hydra.Relational as Relational
import qualified Hydra.Show.Core as ShowCore
import qualified Hydra.Sorting as Sorting
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.Variables as Variables
import qualified Hydra.Variants as Variants
import Prelude hiding  (Enum, Ordering, decodeFloat, encodeFloat, fail, map, pure, sum)
import qualified Data.Scientific as Sci

-- | Dialect-aware name for "cadr" (second element of a list); Clojure uses "second", other dialects use "cadr"
dialectCadr :: Syntax.Dialect -> String
dialectCadr d =
    case d of
      Syntax.DialectClojure -> "second"
      _ -> "cadr"

-- | Dialect-aware name for "car" (first element of a list); Clojure uses "first", other dialects use "car"
dialectCar :: Syntax.Dialect -> String
dialectCar d =
    case d of
      Syntax.DialectClojure -> "first"
      _ -> "car"

-- | Dialect-aware constructor prefix for record types; Clojure uses "->", other dialects use "make-"
dialectConstructorPrefix :: Syntax.Dialect -> String
dialectConstructorPrefix d =
    case d of
      Syntax.DialectClojure -> "->"
      _ -> "make-"

-- | Dialect-aware name for "equal?" (equality test): Clojure uses "=", Common Lisp/Emacs Lisp use "equal", Scheme uses "equal?"
dialectEqual :: Syntax.Dialect -> String
dialectEqual d =
    case d of
      Syntax.DialectClojure -> "="
      Syntax.DialectCommonLisp -> "equal"
      Syntax.DialectEmacsLisp -> "equal"
      _ -> "equal?"

-- | Whether a dialect provides a native letrec (mutually recursive let); Clojure has only sequential let
dialectSupportsLetrec :: Syntax.Dialect -> Bool
dialectSupportsLetrec d =
    case d of
      Syntax.DialectClojure -> False
      _ -> True

-- | Encode a function application, detecting ifElse and other lazy primitives; transforms (((hydra.lib.logic.ifElse C) T) E) into native (if C T E)
encodeApplication :: Syntax.Dialect -> t0 -> Graph.Graph -> Core.Term -> Core.Term -> Either t1 Syntax.Expression
encodeApplication dialect cx g rawFun rawArg =

      let dFun = Strip.deannotateTerm rawFun
          normal =
                  \_ -> Eithers.bind (encodeTerm dialect cx g rawFun) (\fun -> Eithers.bind (encodeTerm dialect cx g rawArg) (\arg -> Right (lispApp fun [
                    arg])))
          enc = \t -> encodeTerm dialect cx g t
      in case dFun of
        Core.TermApplication v0 ->
          let midFun = Core.applicationFunction v0
              midArg = Core.applicationArgument v0
              dMidFun = Strip.deannotateTerm midFun
              isLazy2 = primIsLazyAt g dMidFun 0
          in (Logic.ifElse isLazy2 (Eithers.bind (enc midFun) (\ePrim -> Eithers.bind (enc midArg) (\eDef -> Eithers.bind (enc rawArg) (\eArg -> Right (lispApp (lispApp ePrim [
            wrapInThunk eDef]) [
            eArg]))))) (case dMidFun of
            Core.TermApplication v1 ->
              let innerFun = Core.applicationFunction v1
                  innerArg = Core.applicationArgument v1
                  dInnerFun = Strip.deannotateTerm innerFun
              in (Logic.ifElse (isPrimitiveRef "hydra.lib.logic.ifElse" dInnerFun) (Eithers.bind (enc innerArg) (\eC -> Eithers.bind (enc midArg) (\eT -> Eithers.bind (enc rawArg) (\eE -> Right (Syntax.ExpressionIf (Syntax.IfExpression {
                Syntax.ifExpressionCondition = eC,
                Syntax.ifExpressionThen = eT,
                Syntax.ifExpressionElse = (Just eE)})))))) (Logic.ifElse (primIsLazyAt g dInnerFun 0) (Eithers.bind (enc innerFun) (\eP -> Eithers.bind (enc innerArg) (\eDef -> Eithers.bind (enc midArg) (\eF -> Eithers.bind (enc rawArg) (\eM -> Right (lispApp (lispApp (lispApp eP [
                wrapInThunk eDef]) [
                eF]) [
                eM])))))) (Logic.ifElse (primIsLazyAt g dInnerFun 1) (Eithers.bind (enc innerFun) (\eP -> Eithers.bind (enc innerArg) (\eM -> Eithers.bind (enc midArg) (\eN -> Eithers.bind (enc rawArg) (\eJ -> Right (lispApp (lispApp (lispApp eP [
                eM]) [
                wrapInThunk eN]) [
                eJ])))))) (normal ()))))
            _ -> normal ()))
        _ -> normal ()

encodeFieldDef :: Core.FieldType -> Syntax.FieldDefinition
encodeFieldDef ft =

      let fname = Core.unName (Core.fieldTypeName ft)
      in Syntax.FieldDefinition {
        Syntax.fieldDefinitionName = (Syntax.Symbol (Formatting.convertCaseCamelToLowerSnake fname)),
        Syntax.fieldDefinitionDefaultValue = Nothing}

encodeLambdaTerm :: Syntax.Dialect -> t0 -> Graph.Graph -> Core.Lambda -> Either t1 Syntax.Expression
encodeLambdaTerm dialect cx g lam =

      let param =
              Formatting.convertCaseCamelOrUnderscoreToLowerSnake (Formatting.sanitizeWithUnderscores Language.lispReservedWords (Core.unName (Core.lambdaParameter lam)))
      in (Eithers.bind (encodeTerm dialect cx g (Core.lambdaBody lam)) (\body -> Right (lispLambdaExpr [
        param] body)))

encodeLetAsLambdaApp :: Syntax.Dialect -> t0 -> Graph.Graph -> [Core.Binding] -> Core.Term -> Either t1 Syntax.Expression
encodeLetAsLambdaApp dialect cx g bindings body =
    Eithers.bind (encodeTerm dialect cx g body) (\bodyExpr -> Eithers.foldl (\acc -> \b ->
      let bname =
              Formatting.convertCaseCamelOrUnderscoreToLowerSnake (Formatting.sanitizeWithUnderscores Language.lispReservedWords (Core.unName (Core.bindingName b)))
      in (Eithers.bind (encodeTerm dialect cx g (Core.bindingTerm b)) (\bval -> Right (lispApp (lispLambdaExpr [
        bname] acc) [
        bval])))) bodyExpr (Lists.reverse bindings))

encodeLetAsNative :: Syntax.Dialect -> t0 -> Graph.Graph -> [Core.Binding] -> Core.Term -> Either t1 Syntax.Expression
encodeLetAsNative dialect cx g bindings body =
    Eithers.bind (encodeTerm dialect cx g body) (\bodyExpr ->
      let supportsLetrec = dialectSupportsLetrec dialect
          allNames = Sets.fromList (Lists.map (\b -> Core.bindingName b) bindings)
          adjList =
                  Lists.map (\b -> (Core.bindingName b, (Sets.toList (Sets.intersection allNames (Variables.freeVariablesInTerm (Core.bindingTerm b)))))) bindings
          sccs = Sorting.topologicalSortComponents adjList
          nameToBinding = Maps.fromList (Lists.map (\b -> (Core.bindingName b, b)) bindings)
          sortedBindings = Optionals.cat (Lists.map (\name -> Maps.lookup name nameToBinding) (Lists.concat sccs))
          hasCycle = Lists.foldl (\acc -> \scc -> Logic.or acc (Equality.gt (Lists.length scc) 1)) False sccs
      in (Eithers.bind (Eithers.mapList (\b ->
        let bname =
                Formatting.convertCaseCamelOrUnderscoreToLowerSnake (Formatting.sanitizeWithUnderscores Language.lispReservedWords (Core.unName (Core.bindingName b)))
            isSelfRef = Sets.member (Core.bindingName b) (Variables.freeVariablesInTerm (Core.bindingTerm b))
            isLambda =
                    case (Strip.deannotateTerm (Core.bindingTerm b)) of
                      Core.TermLambda _ -> True
                      _ -> False
        in (Eithers.bind (encodeTerm dialect cx g (Core.bindingTerm b)) (\bval ->
          let isClojure = Logic.not supportsLetrec
              wrappedVal =
                      Logic.ifElse isClojure (Logic.ifElse isSelfRef (Logic.ifElse isLambda (case bval of
                        Syntax.ExpressionLambda v0 -> Syntax.ExpressionLambda (Syntax.Lambda {
                          Syntax.lambdaName = (Just (Syntax.Symbol bname)),
                          Syntax.lambdaParams = (Syntax.lambdaParams v0),
                          Syntax.lambdaRestParam = (Syntax.lambdaRestParam v0),
                          Syntax.lambdaBody = (Syntax.lambdaBody v0)})
                        _ -> bval) (lispNamedLambdaExpr bname [
                        "_arg"] (lispApp bval [
                        lispVar "_arg"]))) bval) (Logic.ifElse (Logic.and isSelfRef (Logic.not isLambda)) (lispLambdaExpr [
                        "_arg"] (lispApp bval [
                        lispVar "_arg"])) bval)
          in (Right (bname, wrappedVal))))) sortedBindings) (\encodedBindings ->
        let hasSelfRef =
                Lists.foldl (\acc -> \b -> Logic.or acc (Sets.member (Core.bindingName b) (Variables.freeVariablesInTerm (Core.bindingTerm b)))) False bindings
            isRecursive = Logic.or hasSelfRef hasCycle
            letKind =
                    Logic.ifElse isRecursive Syntax.LetKindRecursive (Logic.ifElse (Equality.lte (Lists.length bindings) 1) Syntax.LetKindParallel Syntax.LetKindSequential)
            lispBindings =
                    Lists.map (\eb -> Syntax.LetBindingSimple (Syntax.SimpleBinding {
                      Syntax.simpleBindingName = (Syntax.Symbol (Pairs.first eb)),
                      Syntax.simpleBindingValue = (Pairs.second eb)})) encodedBindings
        in (Right (Syntax.ExpressionLet (Syntax.LetExpression {
          Syntax.letExpressionKind = letKind,
          Syntax.letExpressionBindings = lispBindings,
          Syntax.letExpressionBody = [
            bodyExpr]}))))))

encodeLiteral :: Core.Literal -> Syntax.Expression
encodeLiteral lit =
    case lit of
      Core.LiteralBoolean v0 -> Syntax.ExpressionLiteral (Syntax.LiteralBoolean v0)
      Core.LiteralDecimal v0 -> Syntax.ExpressionLiteral (Syntax.LiteralFloat (Syntax.FloatLiteral {
        Syntax.floatLiteralValue = (Literals.decimalToFloat64 v0),
        Syntax.floatLiteralPrecision = Nothing}))
      Core.LiteralString v0 -> Syntax.ExpressionLiteral (Syntax.LiteralString v0)
      Core.LiteralFloat v0 -> case v0 of
        Core.FloatValueFloat32 v1 -> Syntax.ExpressionLiteral (Syntax.LiteralFloat (Syntax.FloatLiteral {
          Syntax.floatLiteralValue = (Literals.float32ToFloat64 v1),
          Syntax.floatLiteralPrecision = Nothing}))
        Core.FloatValueFloat64 v1 -> Syntax.ExpressionLiteral (Syntax.LiteralFloat (Syntax.FloatLiteral {
          Syntax.floatLiteralValue = v1,
          Syntax.floatLiteralPrecision = Nothing}))
      Core.LiteralInteger v0 -> case v0 of
        Core.IntegerValueInt8 v1 -> Syntax.ExpressionLiteral (Syntax.LiteralInteger (Syntax.IntegerLiteral {
          Syntax.integerLiteralValue = (Literals.int8ToBigint v1),
          Syntax.integerLiteralBigint = False}))
        Core.IntegerValueInt16 v1 -> Syntax.ExpressionLiteral (Syntax.LiteralInteger (Syntax.IntegerLiteral {
          Syntax.integerLiteralValue = (Literals.int16ToBigint v1),
          Syntax.integerLiteralBigint = False}))
        Core.IntegerValueInt32 v1 -> Syntax.ExpressionLiteral (Syntax.LiteralInteger (Syntax.IntegerLiteral {
          Syntax.integerLiteralValue = (Literals.int32ToBigint v1),
          Syntax.integerLiteralBigint = False}))
        Core.IntegerValueInt64 v1 -> Syntax.ExpressionLiteral (Syntax.LiteralInteger (Syntax.IntegerLiteral {
          Syntax.integerLiteralValue = (Literals.int64ToBigint v1),
          Syntax.integerLiteralBigint = False}))
        Core.IntegerValueUint8 v1 -> Syntax.ExpressionLiteral (Syntax.LiteralInteger (Syntax.IntegerLiteral {
          Syntax.integerLiteralValue = (Literals.uint8ToBigint v1),
          Syntax.integerLiteralBigint = False}))
        Core.IntegerValueUint16 v1 -> Syntax.ExpressionLiteral (Syntax.LiteralInteger (Syntax.IntegerLiteral {
          Syntax.integerLiteralValue = (Literals.uint16ToBigint v1),
          Syntax.integerLiteralBigint = False}))
        Core.IntegerValueUint32 v1 -> Syntax.ExpressionLiteral (Syntax.LiteralInteger (Syntax.IntegerLiteral {
          Syntax.integerLiteralValue = (Literals.uint32ToBigint v1),
          Syntax.integerLiteralBigint = False}))
        Core.IntegerValueUint64 v1 -> Syntax.ExpressionLiteral (Syntax.LiteralInteger (Syntax.IntegerLiteral {
          Syntax.integerLiteralValue = (Literals.uint64ToBigint v1),
          Syntax.integerLiteralBigint = False}))
        Core.IntegerValueBigint v1 -> Syntax.ExpressionLiteral (Syntax.LiteralInteger (Syntax.IntegerLiteral {
          Syntax.integerLiteralValue = v1,
          Syntax.integerLiteralBigint = True}))
      Core.LiteralBinary v0 ->
        let byteValues = Literals.binaryToBytes v0
        in (Syntax.ExpressionVector (Syntax.VectorLiteral {
          Syntax.vectorLiteralElements = (Lists.map (\bv -> Syntax.ExpressionLiteral (Syntax.LiteralInteger (Syntax.IntegerLiteral {
            Syntax.integerLiteralValue = (Literals.int32ToBigint bv),
            Syntax.integerLiteralBigint = False}))) byteValues)}))

encodeProjectionElim :: Syntax.Dialect -> t0 -> Graph.Graph -> Core.Projection -> Maybe Core.Term -> Either t1 Syntax.Expression
encodeProjectionElim dialect cx g proj marg =

      let fname = Formatting.convertCaseCamelToLowerSnake (Core.unName (Core.projectionFieldName proj))
          tname = qualifiedSnakeName (Core.projectionTypeName proj)
      in (Optionals.cases marg (Right (lispLambdaExpr [
        "__rec"] (Syntax.ExpressionFieldAccess (Syntax.FieldAccess {
        Syntax.fieldAccessRecordType = (Syntax.Symbol tname),
        Syntax.fieldAccessField = (Syntax.Symbol fname),
        Syntax.fieldAccessTarget = (lispVar "__rec")})))) (\arg -> Eithers.bind (encodeTerm dialect cx g arg) (\sarg -> Right (Syntax.ExpressionFieldAccess (Syntax.FieldAccess {
        Syntax.fieldAccessRecordType = (Syntax.Symbol tname),
        Syntax.fieldAccessField = (Syntax.Symbol fname),
        Syntax.fieldAccessTarget = sarg})))))

encodeTerm :: Syntax.Dialect -> t0 -> Graph.Graph -> Core.Term -> Either t1 Syntax.Expression
encodeTerm dialect cx g term =
    case term of
      Core.TermAnnotated v0 -> encodeTerm dialect cx g (Core.annotatedTermBody v0)
      Core.TermApplication v0 ->
        let rawFun = Core.applicationFunction v0
            rawArg = Core.applicationArgument v0
        in (encodeApplication dialect cx g rawFun rawArg)
      Core.TermEither v0 -> Eithers.either (\l -> Eithers.bind (encodeTerm dialect cx g l) (\sl -> Right (lispApp (lispVar "list") [
        lispKeyword "left",
        sl]))) (\r -> Eithers.bind (encodeTerm dialect cx g r) (\sr -> Right (lispApp (lispVar "list") [
        lispKeyword "right",
        sr]))) v0
      Core.TermLambda v0 -> encodeLambdaTerm dialect cx g v0
      Core.TermProject v0 -> encodeProjectionElim dialect cx g v0 Nothing
      Core.TermCases v0 -> encodeUnionElim dialect cx g v0 Nothing
      Core.TermUnwrap v0 -> encodeUnwrapElim dialect cx g v0 Nothing
      Core.TermLet v0 ->
        let bindings = Core.letBindings v0
            body = Core.letBody v0
        in (encodeLetAsNative dialect cx g bindings body)
      Core.TermList v0 -> Eithers.bind (Eithers.mapList (encodeTerm dialect cx g) v0) (\sels -> Right (lispListExpr sels))
      Core.TermLiteral v0 -> Right (encodeLiteral v0)
      Core.TermMap v0 -> Eithers.bind (Eithers.mapList (\entry -> Eithers.bind (encodeTerm dialect cx g (Pairs.first entry)) (\k -> Eithers.bind (encodeTerm dialect cx g (Pairs.second entry)) (\v -> Right (Syntax.MapEntry {
        Syntax.mapEntryKey = k,
        Syntax.mapEntryValue = v})))) (Maps.toList v0)) (\pairs -> Right (Syntax.ExpressionMap (Syntax.MapLiteral {
        Syntax.mapLiteralEntries = pairs})))
      Core.TermOptional v0 -> Optionals.cases v0 (Right (lispApp (lispVar "list") [
        lispKeyword "none"])) (\val -> Eithers.bind (encodeTerm dialect cx g val) (\sval -> Right (lispApp (lispVar "list") [
        lispKeyword "given",
        sval])))
      Core.TermPair v0 -> Eithers.bind (encodeTerm dialect cx g (Pairs.first v0)) (\f -> Eithers.bind (encodeTerm dialect cx g (Pairs.second v0)) (\s -> Right (lispListExpr [
        f,
        s])))
      Core.TermRecord v0 ->
        let rname = Core.recordTypeName v0
            fields = Core.recordFields v0
        in (Eithers.bind (Eithers.mapList (\f -> encodeTerm dialect cx g (Core.fieldTerm f)) fields) (\sfields ->
          let constructorName = Strings.cat2 (dialectConstructorPrefix dialect) (qualifiedSnakeName rname)
          in (Right (lispApp (lispVar constructorName) sfields))))
      Core.TermSet v0 -> Eithers.bind (Eithers.mapList (encodeTerm dialect cx g) (Sets.toList v0)) (\sels -> Right (Syntax.ExpressionSet (Syntax.SetLiteral {
        Syntax.setLiteralElements = sels})))
      Core.TermInject v0 ->
        let tname = Names.localNameOf (Core.injectionTypeName v0)
            field = Core.injectionField v0
            fname = Core.unName (Core.fieldName field)
            fterm = Core.fieldTerm field
            dterm = Strip.deannotateTerm fterm
            isUnit =
                    case dterm of
                      Core.TermUnit -> True
                      Core.TermRecord v1 -> Lists.null (Core.recordFields v1)
                      _ -> False
        in (Logic.ifElse isUnit (Right (lispApp (lispVar "list") [
          lispKeyword (Formatting.convertCaseCamelToLowerSnake fname),
          lispNilExpr])) (Eithers.bind (encodeTerm dialect cx g fterm) (\sval -> Right (lispApp (lispVar "list") [
          lispKeyword (Formatting.convertCaseCamelToLowerSnake fname),
          sval]))))
      Core.TermUnit -> Right lispNilExpr
      Core.TermVariable v0 -> Right (lispVar (Formatting.convertCaseCamelOrUnderscoreToLowerSnake (Formatting.sanitizeWithUnderscores Language.lispReservedWords (Core.unName v0))))
      Core.TermTypeApplication v0 -> encodeTerm dialect cx g (Core.typeApplicationTermBody v0)
      Core.TermTypeLambda v0 -> encodeTerm dialect cx g (Core.typeLambdaBody v0)
      Core.TermWrap v0 -> encodeTerm dialect cx g (Core.wrappedTermBody v0)

encodeTermDefinition :: Syntax.Dialect -> t0 -> Graph.Graph -> Packaging.TermDefinition -> Either t1 Syntax.TopLevelFormWithComments
encodeTermDefinition dialect cx g tdef =

      let name = Packaging.termDefinitionName tdef
          term = Packaging.termDefinitionBody tdef
          lname = qualifiedSnakeName name
          dterm = Strip.deannotateTerm term
      in case dterm of
        Core.TermLambda _ -> Eithers.bind (encodeTerm dialect cx g term) (\sterm -> Right (lispTopForm (Syntax.TopLevelFormVariable (Syntax.VariableDefinition {
          Syntax.variableDefinitionName = (Syntax.Symbol lname),
          Syntax.variableDefinitionValue = sterm,
          Syntax.variableDefinitionDoc = Nothing}))))
        _ -> Eithers.bind (encodeTerm dialect cx g term) (\sterm -> Right (lispTopForm (Syntax.TopLevelFormVariable (Syntax.VariableDefinition {
          Syntax.variableDefinitionName = (Syntax.Symbol lname),
          Syntax.variableDefinitionValue = sterm,
          Syntax.variableDefinitionDoc = Nothing}))))

encodeType :: t0 -> t1 -> Core.Type -> Either t2 Syntax.TypeSpecifier
encodeType cx g t =

      let typ = Strip.deannotateType t
      in case typ of
        Core.TypeAnnotated v0 -> encodeType cx g (Core.annotatedTypeBody v0)
        Core.TypeApplication v0 -> encodeType cx g (Core.applicationTypeFunction v0)
        Core.TypeUnit -> Right Syntax.TypeSpecifierUnit
        Core.TypeLiteral v0 -> Right (case v0 of
          Core.LiteralTypeBinary -> Syntax.TypeSpecifierNamed (Syntax.Symbol "ByteArray")
          Core.LiteralTypeBoolean -> Syntax.TypeSpecifierNamed (Syntax.Symbol "Boolean")
          Core.LiteralTypeDecimal -> Syntax.TypeSpecifierNamed (Syntax.Symbol "Decimal")
          Core.LiteralTypeFloat _ -> Syntax.TypeSpecifierNamed (Syntax.Symbol "Float")
          Core.LiteralTypeInteger _ -> Syntax.TypeSpecifierNamed (Syntax.Symbol "Integer")
          Core.LiteralTypeString -> Syntax.TypeSpecifierNamed (Syntax.Symbol "String"))
        Core.TypeList v0 -> Eithers.map (\enc -> Syntax.TypeSpecifierList enc) (encodeType cx g v0)
        Core.TypeSet v0 -> Eithers.map (\enc -> Syntax.TypeSpecifierSet enc) (encodeType cx g v0)
        Core.TypeMap _ -> Right (Syntax.TypeSpecifierNamed (Syntax.Symbol "Map"))
        Core.TypeOptional v0 -> Eithers.map (\enc -> Syntax.TypeSpecifierMaybe enc) (encodeType cx g v0)
        Core.TypeEither _ -> Right (Syntax.TypeSpecifierNamed (Syntax.Symbol "Either"))
        Core.TypeEffect v0 -> encodeType cx g v0
        Core.TypePair _ -> Right (Syntax.TypeSpecifierNamed (Syntax.Symbol "Pair"))
        Core.TypeFunction _ -> Right (Syntax.TypeSpecifierNamed (Syntax.Symbol "Function"))
        Core.TypeRecord _ -> Right (Syntax.TypeSpecifierNamed (Syntax.Symbol "Record"))
        Core.TypeUnion _ -> Right (Syntax.TypeSpecifierNamed (Syntax.Symbol "Union"))
        Core.TypeWrap _ -> Right (Syntax.TypeSpecifierNamed (Syntax.Symbol "Wrapper"))
        Core.TypeVariable v0 -> Right (Syntax.TypeSpecifierNamed (Syntax.Symbol (Core.unName v0)))
        Core.TypeForall v0 -> encodeType cx g (Core.forallTypeBody v0)
        _ -> Right (Syntax.TypeSpecifierNamed (Syntax.Symbol "Any"))

encodeTypeBody :: String -> Core.Type -> Core.Type -> Either t0 Syntax.TopLevelFormWithComments
encodeTypeBody lname origTyp typ =
    case typ of
      Core.TypeForall v0 -> encodeTypeBody lname origTyp (Core.forallTypeBody v0)
      Core.TypeRecord v0 ->
        let fields = Lists.map encodeFieldDef v0
        in (Right (lispTopForm (Syntax.TopLevelFormRecordType (Syntax.RecordTypeDefinition {
          Syntax.recordTypeDefinitionName = (Syntax.Symbol lname),
          Syntax.recordTypeDefinitionFields = fields,
          Syntax.recordTypeDefinitionDoc = Nothing}))))
      Core.TypeUnion v0 ->
        let variantNames =
                Lists.map (\f -> Syntax.ExpressionLiteral (Syntax.LiteralKeyword (Syntax.Keyword {
                  Syntax.keywordName = (Formatting.convertCaseCamelToLowerSnake (Core.unName (Core.fieldTypeName f))),
                  Syntax.keywordNamespace = Nothing}))) v0
        in (Right (lispTopForm (Syntax.TopLevelFormVariable (Syntax.VariableDefinition {
          Syntax.variableDefinitionName = (Syntax.Symbol (Strings.cat2 lname "-variants")),
          Syntax.variableDefinitionValue = (lispListExpr variantNames),
          Syntax.variableDefinitionDoc = (Just (Syntax.Docstring (Strings.cat2 "Variants of the " lname)))}))))
      Core.TypeWrap _ -> Right (lispTopForm (Syntax.TopLevelFormRecordType (Syntax.RecordTypeDefinition {
        Syntax.recordTypeDefinitionName = (Syntax.Symbol lname),
        Syntax.recordTypeDefinitionFields = [
          Syntax.FieldDefinition {
            Syntax.fieldDefinitionName = (Syntax.Symbol "value"),
            Syntax.fieldDefinitionDefaultValue = Nothing}],
        Syntax.recordTypeDefinitionDoc = Nothing})))
      _ -> Right (Syntax.TopLevelFormWithComments {
        Syntax.topLevelFormWithCommentsDoc = Nothing,
        Syntax.topLevelFormWithCommentsComment = (Just (Syntax.Comment {
          Syntax.commentStyle = Syntax.CommentStyleLine,
          Syntax.commentText = (Strings.cat2 (Strings.cat2 lname " = ") (ShowCore.type_ origTyp))})),
        Syntax.topLevelFormWithCommentsForm = (Syntax.TopLevelFormExpression (Syntax.ExpressionLiteral Syntax.LiteralNil))})

encodeTypeDefinition :: t0 -> t1 -> Packaging.TypeDefinition -> Either t2 Syntax.TopLevelFormWithComments
encodeTypeDefinition cx g tdef =

      let name = Packaging.typeDefinitionName tdef
          typ = Core.typeSchemeBody (Packaging.typeDefinitionBody tdef)
          lname = qualifiedSnakeName name
          dtyp = Strip.deannotateType typ
      in (encodeTypeBody lname typ dtyp)

encodeUnionElim :: Syntax.Dialect -> t0 -> Graph.Graph -> Core.CaseStatement -> Maybe Core.Term -> Either t1 Syntax.Expression
encodeUnionElim dialect cx g cs marg =

      let tname = Names.localNameOf (Core.caseStatementTypeName cs)
          caseFields = Core.caseStatementCases cs
          defCase = Core.caseStatementDefault cs
      in (Eithers.bind (Eithers.mapList (\cf ->
        let cfname = Formatting.convertCaseCamelToLowerSnake (Core.unName (Core.caseAlternativeName cf))
            cfterm = Core.caseAlternativeHandler cf
            condExpr =
                    lispApp (lispVar (dialectEqual dialect)) [
                      lispApp (lispVar (dialectCar dialect)) [
                        lispVar "match_target"],
                      (lispKeyword cfname)]
        in (Eithers.bind (encodeTerm dialect cx g (Core.TermApplication (Core.Application {
          Core.applicationFunction = cfterm,
          Core.applicationArgument = (Core.TermVariable (Core.Name "match_value"))}))) (\bodyExpr -> Right (Syntax.CondClause {
          Syntax.condClauseCondition = condExpr,
          Syntax.condClauseBody = bodyExpr})))) caseFields) (\clauses -> Eithers.bind (Optionals.cases defCase (Right Nothing) (\dt -> Eithers.bind (encodeTerm dialect cx g dt) (\defBody -> Right (Just defBody)))) (\defExpr ->
        let condExpr =
                Syntax.ExpressionCond (Syntax.CondExpression {
                  Syntax.condExpressionClauses = clauses,
                  Syntax.condExpressionDefault = defExpr})
            innerExpr =
                    lispApp (lispLambdaExpr [
                      "match_value"] condExpr) [
                      lispApp (lispVar (dialectCadr dialect)) [
                        lispVar "match_target"]]
        in (Optionals.cases marg (Right (lispLambdaExpr [
          "match_target"] innerExpr)) (\arg -> Eithers.bind (encodeTerm dialect cx g arg) (\sarg -> Right (lispApp (lispLambdaExpr [
          "match_target"] innerExpr) [
          sarg])))))))

encodeUnwrapElim :: Syntax.Dialect -> t0 -> Graph.Graph -> Core.Name -> Maybe Core.Term -> Either t1 Syntax.Expression
encodeUnwrapElim dialect cx g name marg =
    Optionals.cases marg (Right (lispLambdaExpr [
      "__rec"] (lispVar "__rec"))) (\arg -> encodeTerm dialect cx g arg)

isPrimitiveRef :: String -> Core.Term -> Bool
isPrimitiveRef primName term =
    case term of
      Core.TermVariable v0 -> Equality.equal (Core.unName v0) primName
      Core.TermAnnotated v0 -> isPrimitiveRef primName (Core.annotatedTermBody v0)
      Core.TermTypeApplication v0 -> isPrimitiveRef primName (Core.typeApplicationTermBody v0)
      Core.TermTypeLambda v0 -> isPrimitiveRef primName (Core.typeLambdaBody v0)
      _ -> False

lazyFlagsForPrimitiveTerm :: Graph.Graph -> Core.Term -> [Bool]
lazyFlagsForPrimitiveTerm g headTerm =
    Optionals.cases (primHeadName headTerm) [] (\name -> Optionals.cases (Maps.lookup name (Graph.graphPrimitives g)) [] (\prim -> Lists.map (\p -> Typing.parameterIsLazy p) (Typing.termSignatureParameters (Packaging.primitiveDefinitionSignature (Graph.primitiveDefinition prim)))))

lispApp :: Syntax.Expression -> [Syntax.Expression] -> Syntax.Expression
lispApp fun args =
    Syntax.ExpressionApplication (Syntax.Application {
      Syntax.applicationFunction = fun,
      Syntax.applicationArguments = args})

lispKeyword :: String -> Syntax.Expression
lispKeyword name =
    Syntax.ExpressionLiteral (Syntax.LiteralKeyword (Syntax.Keyword {
      Syntax.keywordName = name,
      Syntax.keywordNamespace = Nothing}))

lispLambdaExpr :: [String] -> Syntax.Expression -> Syntax.Expression
lispLambdaExpr params body =
    Syntax.ExpressionLambda (Syntax.Lambda {
      Syntax.lambdaName = Nothing,
      Syntax.lambdaParams = (Lists.map (\p -> Syntax.Symbol p) params),
      Syntax.lambdaRestParam = Nothing,
      Syntax.lambdaBody = [
        body]})

lispListExpr :: [Syntax.Expression] -> Syntax.Expression
lispListExpr elements =
    Syntax.ExpressionList (Syntax.ListLiteral {
      Syntax.listLiteralElements = elements,
      Syntax.listLiteralQuoted = False})

lispLitExpr :: Syntax.Literal -> Syntax.Expression
lispLitExpr lit = Syntax.ExpressionLiteral lit

lispNamedLambdaExpr :: String -> [String] -> Syntax.Expression -> Syntax.Expression
lispNamedLambdaExpr name params body =
    Syntax.ExpressionLambda (Syntax.Lambda {
      Syntax.lambdaName = (Just (Syntax.Symbol name)),
      Syntax.lambdaParams = (Lists.map (\p -> Syntax.Symbol p) params),
      Syntax.lambdaRestParam = Nothing,
      Syntax.lambdaBody = [
        body]})

lispNilExpr :: Syntax.Expression
lispNilExpr = Syntax.ExpressionLiteral Syntax.LiteralNil

lispSymbol :: String -> Syntax.Symbol
lispSymbol name = Syntax.Symbol name

lispTopForm :: Syntax.TopLevelForm -> Syntax.TopLevelFormWithComments
lispTopForm form =
    Syntax.TopLevelFormWithComments {
      Syntax.topLevelFormWithCommentsDoc = Nothing,
      Syntax.topLevelFormWithCommentsComment = Nothing,
      Syntax.topLevelFormWithCommentsForm = form}

lispTopFormWithComments :: Maybe String -> Syntax.TopLevelForm -> Syntax.TopLevelFormWithComments
lispTopFormWithComments mdoc form =
    Syntax.TopLevelFormWithComments {
      Syntax.topLevelFormWithCommentsDoc = (Optionals.map (\d -> Syntax.Docstring d) mdoc),
      Syntax.topLevelFormWithCommentsComment = Nothing,
      Syntax.topLevelFormWithCommentsForm = form}

lispVar :: String -> Syntax.Expression
lispVar name =
    Syntax.ExpressionVariable (Syntax.VariableReference {
      Syntax.variableReferenceName = (Syntax.Symbol name),
      Syntax.variableReferenceFunctionNamespace = False})

moduleExports :: [Syntax.TopLevelFormWithComments] -> [Syntax.ExportDeclaration]
moduleExports forms =

      let symbols =
              Lists.concat (Lists.map (\fwc ->
                let form = Syntax.topLevelFormWithCommentsForm fwc
                in case form of
                  Syntax.TopLevelFormVariable v0 -> [
                    Syntax.variableDefinitionName v0]
                  Syntax.TopLevelFormRecordType v0 ->
                    let rname = Syntax.unSymbol (Syntax.recordTypeDefinitionName v0)
                        fields = Syntax.recordTypeDefinitionFields v0
                        fieldSyms =
                                Lists.map (\f ->
                                  let fn = Syntax.unSymbol (Syntax.fieldDefinitionName f)
                                  in (Syntax.Symbol (Strings.cat [
                                    rname,
                                    "-",
                                    fn]))) fields
                    in (Lists.concat [
                      [
                        Syntax.Symbol (Strings.cat2 "make-" rname),
                        (Syntax.Symbol (Strings.cat2 rname "?"))],
                      fieldSyms])
                  _ -> []) forms)
      in (Logic.ifElse (Lists.null symbols) [] [
        Syntax.ExportDeclaration {
          Syntax.exportDeclarationSymbols = symbols}])

moduleImports :: Packaging.ModuleName -> [Packaging.Definition] -> [Syntax.ImportDeclaration]
moduleImports focusNs defs =

      let depNss = Sets.toList (Sets.delete focusNs (Analysis.definitionDependencyModuleNames defs))
      in (Lists.map (\ns -> Syntax.ImportDeclaration {
        Syntax.importDeclarationModule = (Syntax.NamespaceName (Packaging.unModuleName ns)),
        Syntax.importDeclarationSpec = Syntax.ImportSpecAll}) depNss)

moduleToLisp :: Syntax.Dialect -> Packaging.Module -> [Packaging.Definition] -> t0 -> Graph.Graph -> Either t1 Syntax.Program
moduleToLisp dialect mod defs0 cx g =

      let defs = Environment.reorderDefs defs0
          partitioned = Environment.partitionDefinitions defs
          allTypeDefs = Pairs.first partitioned
          termDefs = Pairs.second partitioned
          typeDefs =
                  Lists.filter (\td -> Predicates.isNominalType (Core.typeSchemeBody (Packaging.typeDefinitionBody td))) allTypeDefs
      in (Eithers.bind (Eithers.mapList (encodeTypeDefinition cx g) typeDefs) (\typeItems -> Eithers.bind (Eithers.mapList (encodeTermDefinition dialect cx g) termDefs) (\termItems ->
        let allItems = Lists.concat2 typeItems termItems
            nsName = Packaging.unModuleName (Packaging.moduleName mod)
            focusNs = Packaging.moduleName mod
            imports = moduleImports focusNs defs
            exports = moduleExports allItems
        in (Right (Syntax.Program {
          Syntax.programDialect = dialect,
          Syntax.programModule = (Just (Syntax.ModuleDeclaration {
            Syntax.moduleDeclarationName = (Syntax.NamespaceName nsName),
            Syntax.moduleDeclarationDoc = Nothing})),
          Syntax.programImports = imports,
          Syntax.programExports = exports,
          Syntax.programForms = allItems})))))

primHeadName :: Core.Term -> Maybe Core.Name
primHeadName term =
    case term of
      Core.TermVariable v0 -> Just v0
      Core.TermAnnotated v0 -> primHeadName (Core.annotatedTermBody v0)
      Core.TermTypeApplication v0 -> primHeadName (Core.typeApplicationTermBody v0)
      Core.TermTypeLambda v0 -> primHeadName (Core.typeLambdaBody v0)
      _ -> Nothing

primIsLazyAt :: Graph.Graph -> Core.Term -> Int -> Bool
primIsLazyAt g headTerm i = Optionals.fromOptional False (Lists.maybeAt i (lazyFlagsForPrimitiveTerm g headTerm))

qualifiedSnakeName :: Core.Name -> String
qualifiedSnakeName name =

      let raw = Core.unName name
          parts = Strings.splitOn "." raw
          snakeParts = Lists.map (\p -> Formatting.convertCaseCamelOrUnderscoreToLowerSnake p) parts
          joined = Strings.intercalate "_" snakeParts
      in (Formatting.sanitizeWithUnderscores Language.lispReservedWords joined)

qualifiedTypeName :: Core.Name -> String
qualifiedTypeName name = Formatting.capitalize (Names.localNameOf name)

wrapInThunk :: Syntax.Expression -> Syntax.Expression
wrapInThunk expr =
    Syntax.ExpressionLambda (Syntax.Lambda {
      Syntax.lambdaName = Nothing,
      Syntax.lambdaParams = [],
      Syntax.lambdaRestParam = Nothing,
      Syntax.lambdaBody = [
        expr]})