module Proteome.Tags.Menu where

import qualified Data.Text as Text
import Exon (exon)
import Path.IO (doesFileExist)
import Prelude hiding (tag)
import Ribosome (
  Args (Args),
  Handler,
  Report,
  Rpc,
  RpcError,
  ScratchId (ScratchId),
  SettingError,
  Settings,
  mapReport,
  pathText,
  resumeReport,
  )
import Ribosome.Host.Data.Report (ReportLog)
import Ribosome.Menu (Filter (Fuzzy), MenuItem, MenuResult, WindowMenus, modal, windowMenu)
import qualified Streamly.Prelude as Stream
import Streamly.Prelude (SerialT)

import Proteome.Data.Env (Env, mainType)
import Proteome.Menu (handleResult)
import Proteome.Tags.Cycle (cword)
import Proteome.Tags.Mappings (TagsAction (Navigate), mappings)
import Proteome.Tags.Nav (loadOrEdit)
import Proteome.Tags.Query (query)
import Proteome.Tags.State (
  RawTagSegments,
  Segment (Module, Name),
  Tag,
  TagSegments,
  TagsMode (TagsMode),
  TagsState,
  tagSegmentsFor,
  )
import Proteome.Tags.Stream (readTags)
import Proteome.Tags.Syntax (tagsSyntax)

getTags ::
  Members [AtomicState Env, Rpc] r =>
  (RawTagSegments -> TagSegments) ->
  Maybe Text ->
  Sem r (SerialT IO (MenuItem Tag))
getTags :: forall (r :: EffectRow).
Members '[AtomicState Env, Rpc] r =>
(RawTagSegments -> TagSegments)
-> Maybe Text -> Sem r (SerialT IO (MenuItem Tag))
getTags RawTagSegments -> TagSegments
mkSegments = \case
  Just Text
rex -> do
    [MenuItem Tag] -> SerialT IO (MenuItem Tag)
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, IsStream t) =>
[a] -> t m a
Stream.fromList ([MenuItem Tag] -> SerialT IO (MenuItem Tag))
-> Sem r [MenuItem Tag] -> Sem r (SerialT IO (MenuItem Tag))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RawTagSegments -> TagSegments) -> Text -> Sem r [MenuItem Tag]
forall (r :: EffectRow).
Member Rpc r =>
(RawTagSegments -> TagSegments) -> Text -> Sem r [MenuItem Tag]
query RawTagSegments -> TagSegments
mkSegments Text
rex
  Maybe Text
Nothing ->
    (RawTagSegments -> TagSegments)
-> Member Rpc r => Sem r (SerialT IO (MenuItem Tag))
forall (r :: EffectRow).
(RawTagSegments -> TagSegments)
-> Member Rpc r => Sem r (SerialT IO (MenuItem Tag))
readTags RawTagSegments -> TagSegments
mkSegments

tagsAction ::
  Members [Rpc, Stop Report, Embed IO] r =>
  TagsAction ->
  Sem r ()
tagsAction :: forall (r :: EffectRow).
Members '[Rpc, Stop Report, Embed IO] r =>
TagsAction -> Sem r ()
tagsAction = \case
  Navigate Path Abs File
path Int
line -> do
    Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Path Abs File -> Sem r Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path) do
      Report -> Sem r ()
forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop (Text -> Report
forall a. IsString a => Text -> a
fromText [exon|File doesn't exist: #{pathText path}|])
    Path Abs File -> Int -> Sem r ()
forall (r :: EffectRow).
Member Rpc r =>
Path Abs File -> Int -> Sem r ()
loadOrEdit Path Abs File
path Int
line

type TagsStack =
  [
    WindowMenus () TagsState !! RpcError,
    Settings !! SettingError,
    Rpc !! RpcError,
    Log
  ]

tagsMenu ::
  Members TagsStack r =>
  Members [AtomicState Env, Rpc, ReportLog, Stop Report, Embed IO] r =>
  Maybe Text ->
  Sem r (MenuResult TagsAction)
tagsMenu :: forall (r :: EffectRow).
(Members TagsStack r,
 Members
   '[AtomicState Env, Rpc, ReportLog, Stop Report, Embed IO] r) =>
Maybe Text -> Sem r (MenuResult TagsAction)
tagsMenu Maybe Text
rex = do
  Maybe ProjectType
tpe <- (Env -> Maybe ProjectType) -> Sem r (Maybe ProjectType)
forall s s' (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets Env -> Maybe ProjectType
mainType
  SerialT IO (MenuItem Tag)
tags <- (RawTagSegments -> TagSegments)
-> Maybe Text -> Sem r (SerialT IO (MenuItem Tag))
forall (r :: EffectRow).
Members '[AtomicState Env, Rpc] r =>
(RawTagSegments -> TagSegments)
-> Maybe Text -> Sem r (SerialT IO (MenuItem Tag))
getTags (Maybe ProjectType -> RawTagSegments -> TagSegments
tagSegmentsFor Maybe ProjectType
tpe) Maybe Text
rex
  Sem (Stop RpcError : r) (MenuResult TagsAction)
-> Sem r (MenuResult TagsAction)
forall e (r :: EffectRow) a.
(Reportable e, Member (Stop Report) r) =>
Sem (Stop e : r) a -> Sem r a
mapReport do
    SerialT IO (MenuItem (Item (Modal TagsMode Tag)))
-> Modal TagsMode Tag
-> WindowOptions
-> Mappings (Modal TagsMode Tag) (Stop RpcError : r) TagsAction
-> Sem (Stop RpcError : r) (MenuResult TagsAction)
forall res result s (r :: EffectRow).
(MenuState s,
 Members
   '[UiMenus WindowConfig res s !! RpcError, Log, Stop RpcError] r) =>
SerialT IO (MenuItem (Item s))
-> s
-> WindowOptions
-> Mappings s r result
-> Sem r (MenuResult result)
windowMenu SerialT IO (MenuItem (Item (Modal TagsMode Tag)))
SerialT IO (MenuItem Tag)
tags (TagsMode -> Modal TagsMode Tag
forall mode i. mode -> Modal mode i
modal (Filter -> Segment -> TagsMode
TagsMode Filter
Fuzzy Segment
mode)) (WindowOptions
forall a. Default a => a
def WindowOptions -> (WindowOptions -> WindowOptions) -> WindowOptions
forall a b. a -> (a -> b) -> b
& IsLabel
  "items"
  (ASetter WindowOptions WindowOptions ScratchOptions ScratchOptions)
ASetter WindowOptions WindowOptions ScratchOptions ScratchOptions
#items ASetter WindowOptions WindowOptions ScratchOptions ScratchOptions
-> ScratchOptions -> WindowOptions -> WindowOptions
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ScratchOptions
scratchOptions) Mappings (Modal TagsMode Tag) (Stop RpcError : r) TagsAction
forall (r :: EffectRow).
Members '[Rpc, ReportLog, Embed IO] r =>
Mappings (Modal TagsMode Tag) r TagsAction
mappings
  where
    mode :: Segment
mode =
      if Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
rex then Segment
Module else Segment
Name
    scratchOptions :: ScratchOptions
scratchOptions =
      ScratchOptions
forall a. Default a => a
def
      ScratchOptions
-> (ScratchOptions -> ScratchOptions) -> ScratchOptions
forall a b. a -> (a -> b) -> b
& IsLabel
  "name" (ASetter ScratchOptions ScratchOptions ScratchId ScratchId)
ASetter ScratchOptions ScratchOptions ScratchId ScratchId
#name ASetter ScratchOptions ScratchOptions ScratchId ScratchId
-> ScratchId -> ScratchOptions -> ScratchOptions
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> ScratchId
ScratchId Text
name
      ScratchOptions
-> (ScratchOptions -> ScratchOptions) -> ScratchOptions
forall a b. a -> (a -> b) -> b
& IsLabel
  "syntax" (ASetter ScratchOptions ScratchOptions [Syntax] [Syntax])
ASetter ScratchOptions ScratchOptions [Syntax] [Syntax]
#syntax ASetter ScratchOptions ScratchOptions [Syntax] [Syntax]
-> [Syntax] -> ScratchOptions -> ScratchOptions
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item [Syntax]
Syntax
tagsSyntax]
      ScratchOptions
-> (ScratchOptions -> ScratchOptions) -> ScratchOptions
forall a b. a -> (a -> b) -> b
& IsLabel
  "filetype"
  (ASetter ScratchOptions ScratchOptions (Maybe Text) (Maybe Text))
ASetter ScratchOptions ScratchOptions (Maybe Text) (Maybe Text)
#filetype ASetter ScratchOptions ScratchOptions (Maybe Text) (Maybe Text)
-> Text -> ScratchOptions -> ScratchOptions
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
name
    name :: Text
name =
      Text
"proteome-tags"

tagsMenuHandle ::
  Members TagsStack r =>
  Members [AtomicState Env, Rpc, ReportLog, Stop Report, Embed IO] r =>
  Maybe Text ->
  Sem r ()
tagsMenuHandle :: forall (r :: EffectRow).
(Members TagsStack r,
 Members
   '[AtomicState Env, Rpc, ReportLog, Stop Report, Embed IO] r) =>
Maybe Text -> Sem r ()
tagsMenuHandle =
  (TagsAction -> Sem r ()) -> MenuResult TagsAction -> Sem r ()
forall (r :: EffectRow) a.
Members '[Rpc, Stop Report] r =>
(a -> Sem r ()) -> MenuResult a -> Sem r ()
handleResult TagsAction -> Sem r ()
forall (r :: EffectRow).
Members '[Rpc, Stop Report, Embed IO] r =>
TagsAction -> Sem r ()
tagsAction (MenuResult TagsAction -> Sem r ())
-> (Maybe Text -> Sem r (MenuResult TagsAction))
-> Maybe Text
-> Sem r ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Maybe Text -> Sem r (MenuResult TagsAction)
forall (r :: EffectRow).
(Members TagsStack r,
 Members
   '[AtomicState Env, Rpc, ReportLog, Stop Report, Embed IO] r) =>
Maybe Text -> Sem r (MenuResult TagsAction)
tagsMenu

proTags ::
  Members TagsStack r =>
  Members [AtomicState Env, ReportLog, Embed IO] r =>
  Args ->
  Handler r ()
proTags :: forall (r :: EffectRow).
(Members TagsStack r,
 Members '[AtomicState Env, ReportLog, Embed IO] r) =>
Args -> Handler r ()
proTags (Args Text
rex) =
  forall (eff :: (* -> *) -> * -> *) e (r :: EffectRow) a.
(Reportable e, Members '[eff !! e, Stop Report] r) =>
Sem (eff : r) a -> Sem r a
resumeReport @Rpc do
    Maybe Text -> Sem (Rpc : Stop Report : r) ()
forall (r :: EffectRow).
(Members TagsStack r,
 Members
   '[AtomicState Env, Rpc, ReportLog, Stop Report, Embed IO] r) =>
Maybe Text -> Sem r ()
tagsMenuHandle (if Text -> Bool
Text.null Text
rex then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
rex)

exactQuery ::
  Member Rpc r =>
  Text ->
  Sem r Text
exactQuery :: forall (r :: EffectRow). Member Rpc r => Text -> Sem r Text
exactQuery =
  (Text -> Text) -> Sem r Text -> Sem r Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
forall {inner} {builder}.
(ExonAppend inner builder, ExonString inner builder,
 ExonBuilder inner builder) =>
inner -> inner
exact (Sem r Text -> Sem r Text)
-> (Text -> Sem r Text) -> Text -> Sem r Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Text
"" ->
      Sem r Text
forall (r :: EffectRow). Member Rpc r => Sem r Text
cword
    Text
rex ->
      Text -> Sem r Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
rex
  where
    exact :: inner -> inner
exact inner
rex =
      [exon|^#{rex}$|]

proTag ::
  Members TagsStack r =>
  Members [AtomicState Env, ReportLog, Embed IO] r =>
  Args ->
  Handler r ()
proTag :: forall (r :: EffectRow).
(Members TagsStack r,
 Members '[AtomicState Env, ReportLog, Embed IO] r) =>
Args -> Handler r ()
proTag (Args Text
name) = do
  forall (eff :: (* -> *) -> * -> *) e (r :: EffectRow) a.
(Reportable e, Members '[eff !! e, Stop Report] r) =>
Sem (eff : r) a -> Sem r a
resumeReport @Rpc do
    Text
rex <- Text -> Sem (Rpc : Stop Report : r) Text
forall (r :: EffectRow). Member Rpc r => Text -> Sem r Text
exactQuery Text
name
    Maybe Text -> Sem (Rpc : Stop Report : r) ()
forall (r :: EffectRow).
(Members TagsStack r,
 Members
   '[AtomicState Env, Rpc, ReportLog, Stop Report, Embed IO] r) =>
Maybe Text -> Sem r ()
tagsMenuHandle (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
rex)