content: {-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
  
  module Lamdu.Sugar.Convert.NodeActions.SetToLiteral
      ( makeSetToLiteral
      ) where
  
  import qualified Control.Lens.Extended as Lens
  import qualified Data.Map as Map
  import qualified Data.Property as Property
  import           Data.Text.Encoding (encodeUtf8)
  import           Hyper
  import           Hyper.Syntax.Nominal (ToNom(..), NominalDecl(..), NominalInst(..))
  import qualified Hyper.Syntax.Scheme as S
  import qualified Lamdu.Builtins.Anchors as Builtins
  import qualified Lamdu.Builtins.PrimVal as PrimVal
  import           Lamdu.Calc.Definition (depsNominals)
  import           Lamdu.Calc.Term (Val)
  import qualified Lamdu.Calc.Term as V
  import qualified Lamdu.Calc.Type as T
  import qualified Lamdu.Expr.IRef as ExprIRef
  import qualified Lamdu.Sugar.Convert.Input as Input
  import           Lamdu.Sugar.Convert.Monad (ConvertM(..))
  import qualified Lamdu.Sugar.Convert.Monad as ConvertM
  import qualified Lamdu.Sugar.Internal.EntityId as EntityId
  import           Lamdu.Sugar.Types
  import           Revision.Deltum.Transaction (Transaction)
  
  import           Lamdu.Prelude
  
  type T = Transaction
  
  makeSetToLiteral ::
      Monad m =>
      Input.Payload m # V.Term -> ConvertM m (Literal Identity -> T m EntityId)
  makeSetToLiteral exprPl =
      (,) <$> ConvertM.typeProtectedSetToVal <*> valFromLiteral
      <&>
      \(setToVal, valFromLit) lit ->
      let (x, update) = valFromLit lit
      in
      do
          update
          l <-
              x & hflipped %~ hmap (const (const (ExprIRef.WriteNew :*: Const ())))
              & hAnn . _1 .~ ExprIRef.ExistingRef (exprPl ^. Input.stored . ExprIRef.iref)
              & ExprIRef.writeRecursively
              <&> (^. hAnn . _1)
          _ <- setToVal (exprPl ^. Input.stored) l
          EntityId.ofValI l & pure
  
  valFromLiteral ::
      Monad m =>
      ConvertM m (Literal Identity -> (Val (Pure # T.Type), T m ()))
  valFromLiteral =
      Lens.view ConvertM.scFrozenDeps
      <&>
      \frozenDeps ->
      \case
      LiteralNum (Identity x) -> (literalExpr (PrimVal.Float x), pure ())
      LiteralBytes (Identity x) -> (literalExpr (PrimVal.Bytes x), pure ())
      LiteralChar (Identity x) -> (literalExpr (PrimVal.Char x), pure ())
      LiteralText (Identity x) ->
          ( encodeUtf8 x
              & PrimVal.Bytes
              & literalExpr
              & ToNom Builtins.textTid
              & V.BToNom
              & Ann (Lens._Wrapped . _Pure # T.TInst (NominalInst Builtins.textTid noParams))
          , Property.pureModify frozenDeps (<> textDep)
          )
      where
          literalExpr v =
              V.LLiteral prim & V.BLeaf
              & Ann (Lens._Wrapped . _Pure # T.TInst (NominalInst (prim ^. V.primType) noParams))
              where
                  prim = PrimVal.fromKnown v
          noParams = T.Types (S.QVarInstances mempty) (S.QVarInstances mempty)
          textDep =
              mempty
              & depsNominals .~
                  Map.singleton Builtins.textTid
                  ( _Pure # NominalDecl
                  { _nParams = T.Types (S.QVars mempty) (S.QVars mempty)
                  , _nScheme =
                      S.Scheme
                      { S._sForAlls = T.Types (S.QVars mempty) (S.QVars mempty)
                      , S._sTyp = _Pure . T._TInst # NominalInst Builtins.bytesTid noParams
                      }
                  })
  