content: {-# LANGUAGE TypeFamilies #-}
  module Lamdu.Data.Ops
      ( newHole, applyHoleTo, setToAppliedHole
      , replace, replaceWithHole, setToHole, lambdaWrap, redexWrap
      , redexWrapWithGivenParam
      , genNewTag, assocTagName
      , newPublicDefinitionWithPane, newEmptyPublicDefinitionWithPane
      , newPublicDefinitionToIRef
      , newPane
      , newIdentityLambda
      , setTagOrder
      ) where
  
  import qualified Control.Lens as Lens
  import           Control.Lens.Extended ((~~>))
  import qualified Data.ByteString.Extended as BS
  import           Data.Char (toLower)
  import           Data.Property (MkProperty', Property(..))
  import qualified Data.Property as Property
  import qualified Data.Set as Set
  import qualified Data.UUID as UUID
  import qualified GUI.Momentu.Direction as Dir
  import           Hyper (_HCompose)
  import           Hyper.Type.Prune (Prune(..))
  import           Hyper.Syntax.Scheme (Scheme(..), QVars(..))
  import           Lamdu.Calc.Identifier (Identifier(..))
  import qualified Lamdu.Calc.Term as V
  import qualified Lamdu.Calc.Type as T
  import qualified Lamdu.CharClassification as Chars
  import qualified Lamdu.Data.Anchors as Anchors
  import           Lamdu.Data.Definition (Definition(..))
  import qualified Lamdu.Data.Definition as Definition
  import           Lamdu.Data.Meta (SpecialArgs(..), PresentationMode)
  import           Lamdu.Data.Tag (Symbol(..), TextsInLang(..), tagOrder, tagTexts, tagSymbol, getTagName, name)
  import           Lamdu.Expr.IRef (DefI, HRef, ValI)
  import qualified Lamdu.Expr.IRef as ExprIRef
  import           Lamdu.I18N.LangId (LangId)
  import           Revision.Deltum.Transaction (Transaction)
  import qualified Revision.Deltum.Transaction as Transaction
  
  import           Lamdu.Prelude
  
  type T = Transaction
  
  setToAppliedHole :: Monad m => ValI m -> HRef m # V.Term -> T m (ValI m)
  setToAppliedHole innerI destP =
      do
          newFuncI <- newHole
          resI <- ExprIRef.newValI . V.BApp $ V.App newFuncI innerI
          (destP ^. ExprIRef.setIref) resI
          pure resI
  
  applyHoleTo :: Monad m => HRef m # V.Term -> T m (ValI m)
  applyHoleTo exprP = setToAppliedHole (exprP ^. ExprIRef.iref) exprP
  
  newHole :: Monad m => T m (ValI m)
  newHole = ExprIRef.newValI $ V.BLeaf V.LHole
  
  replace :: Monad m => HRef m # V.Term -> ValI m -> T m (ValI m)
  replace exprP newExprI = newExprI <$ (exprP ^. ExprIRef.setIref) newExprI
  
  replaceWithHole :: Monad m => HRef m # V.Term -> T m (ValI m)
  replaceWithHole exprP = replace exprP =<< newHole
  
  setToHole :: Monad m => HRef m # V.Term -> T m (ValI m)
  setToHole exprP =
      exprI <$ ExprIRef.writeValI exprI hole
      where
          hole = V.BLeaf V.LHole
          exprI = exprP ^. ExprIRef.iref
  
  lambdaWrap :: Monad m => HRef m # V.Term -> T m (V.Var, HRef m # V.Term)
  lambdaWrap exprP =
      do
          newParam <- ExprIRef.newVar
          t <- _HCompose # Pruned & ExprIRef.newValI
          newExprI <-
              exprP ^. ExprIRef.iref & V.TypedLam newParam t & V.BLam
              & ExprIRef.newValI
          (newParam, exprP & ExprIRef.iref .~ newExprI) <$
              (exprP ^. ExprIRef.setIref) newExprI
  
  redexWrapWithGivenParam ::
      Monad m =>
      V.Var -> ValI m -> HRef m # V.Term -> T m (HRef m # V.Term)
  redexWrapWithGivenParam param newValueI exprP =
      do
          newLambdaI <- exprP ^. ExprIRef.iref & mkLam >>= ExprIRef.newValI
          newApplyI <- ExprIRef.newValI . V.BApp $ V.App newLambdaI newValueI
          let newSet v = mkLam v >>= ExprIRef.writeValI newLambdaI
          (exprP & ExprIRef.setIref .~ newSet) <$ (exprP ^. ExprIRef.setIref) newApplyI
      where
          mkLam b =
              _HCompose # Pruned & ExprIRef.newValI
              <&> (V.TypedLam param ?? b) <&> V.BLam
  
  redexWrap :: Monad m => HRef m # V.Term -> T m (ValI m)
  redexWrap exprP =
      do
          newValueI <- newHole
          newParam <- ExprIRef.newVar
          _ <- redexWrapWithGivenParam newParam newValueI exprP
          pure newValueI
  
  genNewTag :: Monad m => T m T.Tag
  genNewTag = Transaction.newKey <&> T.Tag . Identifier . BS.strictify . UUID.toByteString
  
  assocTagName ::
      (Monad f, MonadReader env m, Has LangId env, Has Dir.Layout env) =>
      m (T.Tag -> MkProperty' (T f) Text)
  assocTagName =
      Lens.view id <&>
      \env tag ->
      let lang = env ^. has
          result info =
              Property (getTagName env info ^. _2 . name)
              (Transaction.writeIRef (ExprIRef.tagI tag) . setName)
              where
                  setName x
                      | x == mempty =
                          info
                          & tagSymbol .~ NoSymbol
                          & tagTexts . Lens.at lang .~ Nothing
                      | isOperator x =
                          info
                          & tagSymbol .~ UniversalSymbol x
                          & tagTexts . Lens.at lang .~ Nothing
                      | otherwise =
                          info
                          & tagSymbol .~ NoSymbol
                          & tagTexts . Lens.at lang ?~
                              TextsInLang (x & Lens.ix 0 %~ toLower) Nothing Nothing
          isOperator = Lens.allOf Lens.each (`elem` Chars.operator)
      in  ExprIRef.readTagData tag
          <&> result
          & Property.MkProperty
  
  newPane :: Monad m => Anchors.CodeAnchors m -> Anchors.Pane m -> T m ()
  newPane codeAnchors pane =
      do
          Property panes setPanes <-
              Anchors.panes codeAnchors ^. Property.mkProperty
          panes ++ [pane] & setPanes & unless (pane `elem` panes)
  
  newDefinition :: Monad m => PresentationMode -> Definition (ValI m) () -> T m (DefI m)
  newDefinition presentationMode def =
      do
          newDef <- Transaction.newIRef def
          let defVar = ExprIRef.globalId newDef
          Property.setP (Anchors.assocPresentationMode defVar) presentationMode
          pure newDef
  
  -- Used when writing a definition into an identifier which was a variable.
  -- Used in float.
  newPublicDefinitionToIRef ::
      Monad m => Anchors.CodeAnchors m -> Definition (ValI m) () -> DefI m -> T m ()
  newPublicDefinitionToIRef codeAnchors def defI =
      do
          Transaction.writeIRef defI def
          Property.modP (Anchors.globals codeAnchors) (Set.insert defI)
          newPane codeAnchors (Anchors.PaneDefinition defI)
  
  newPublicDefinitionWithPane ::
      Monad m =>
      Anchors.CodeAnchors m -> Definition (ValI m) () -> T m (DefI m)
  newPublicDefinitionWithPane codeAnchors def =
      do
          defI <- newDefinition Verbose def
          Property.modP (Anchors.globals codeAnchors) (Set.insert defI)
          newPane codeAnchors (Anchors.PaneDefinition defI)
          pure defI
  
  newEmptyPublicDefinitionWithPane :: Monad m => Anchors.CodeAnchors m -> T m (DefI m)
  newEmptyPublicDefinitionWithPane cp =
      do
          holeI <- newHole
          Definition
              (Definition.BodyExpr (Definition.Expr holeI mempty))
              ( _Pure # Scheme
                  { _sForAlls =
                      T.Types (QVars ("a" ~~> mempty)) (QVars mempty)
                  , _sTyp = _Pure # T.TVar "a"
              }) ()
              & newPublicDefinitionWithPane cp
  
  newIdentityLambda :: Monad m => T m (V.Var, ValI m)
  newIdentityLambda =
      do
          paramId <- ExprIRef.newVar
          getVar <- V.LVar paramId & V.BLeaf & ExprIRef.newValI
          paramType <- _HCompose # Pruned & ExprIRef.newValI
          lamI <- V.TypedLam paramId paramType getVar & V.BLam & ExprIRef.newValI
          pure (paramId, lamI)
  
  setTagOrder :: Monad m => T.Tag -> Int -> T m ()
  setTagOrder tag order =
      ExprIRef.readTagData tag
      <&> tagOrder .~ order
      >>= Transaction.writeIRef (ExprIRef.tagI tag)
  