module Proteome.Diag where

import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import Exon (exon)
import Path (toFilePath)
import Prettyprinter (Doc, line, nest, pretty, vsep)
import Ribosome (
  Handler,
  Report (Report),
  ReportContext,
  Reports,
  RpcError,
  Scratch,
  ScratchId (ScratchId),
  Settings,
  StoredReport (StoredReport),
  reportContext,
  resumeReport,
  scratch,
  storedReports,
  )
import qualified Ribosome.Scratch as Scratch
import Ribosome.Scratch (ScratchOptions (filetype, focus))

import qualified Proteome.Data.Env as Env
import Proteome.Data.Env (Env)
import Proteome.Data.Project (Project (Project))
import Proteome.Data.ProjectLang (ProjectLang (ProjectLang, unProjectLang))
import Proteome.Data.ProjectMetadata (ProjectMetadata (DirProject, VirtualProject))
import Proteome.Data.ProjectName (ProjectName (ProjectName))
import Proteome.Data.ProjectRoot (ProjectRoot (ProjectRoot))
import Proteome.Data.ProjectType (ProjectType (ProjectType, unProjectType))
import Proteome.Tags.Gen (tagsCommand)

formatLang :: Maybe ProjectLang -> Text
formatLang :: Maybe ProjectLang -> Text
formatLang (Just (ProjectLang Text
lang)) = Text
lang
formatLang Maybe ProjectLang
Nothing = Text
"none"

formatType :: Maybe ProjectType -> Text
formatType :: Maybe ProjectType -> Text
formatType (Just (ProjectType Text
tpe)) = Text
tpe
formatType Maybe ProjectType
Nothing = Text
"none"

formatProject :: ProjectName -> ProjectRoot -> Maybe ProjectType -> [Text]
formatProject :: ProjectName -> ProjectRoot -> Maybe ProjectType -> [Text]
formatProject (ProjectName Text
name) (ProjectRoot Path Abs Dir
root) Maybe ProjectType
tpe =
  [
    Text
"name: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name,
    Text
"root: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text)
-> (Path Abs Dir -> FilePath) -> Path Abs Dir -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath) Path Abs Dir
root,
    Text
"type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe ProjectType -> Text
formatType Maybe ProjectType
tpe
  ]

formatMeta ::
  Member (Settings !! se) r =>
  ProjectMetadata ->
  [ProjectLang] ->
  Sem r [Text]
formatMeta :: forall se (r :: EffectRow).
Member (Settings !! se) r =>
ProjectMetadata -> [ProjectLang] -> Sem r [Text]
formatMeta (VirtualProject (ProjectName Text
name)) [ProjectLang]
_ =
  [Text] -> Sem r [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text
"name: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name]
formatMeta (DirProject ProjectName
name ProjectRoot
root Maybe ProjectType
tpe) [ProjectLang]
langs = do
  [Text]
tags :: [Text] <- [Text] -> Sem (Settings : r) [Text] -> Sem r [Text]
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Resumable err eff) r =>
a -> Sem (eff : r) a -> Sem r a
resumeAs [] do
    Sem (Stop TagsError : Settings : r) (Text, Text)
-> Sem (Settings : r) (Either TagsError (Text, Text))
forall e (r :: EffectRow) a.
Sem (Stop e : r) a -> Sem r (Either e a)
runStop (ProjectRoot
-> [ProjectLang]
-> Sem (Stop TagsError : Settings : r) (Text, Text)
forall (r :: EffectRow).
Members '[Settings, Stop TagsError] r =>
ProjectRoot -> [ProjectLang] -> Sem r (Text, Text)
tagsCommand ProjectRoot
root [ProjectLang]
langs) Sem (Settings : r) (Either TagsError (Text, Text))
-> (Either TagsError (Text, Text) -> Sem (Settings : r) [Text])
-> Sem (Settings : r) [Text]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right (Text
tagsCmd, Text
tagsArgs) ->
        [Text] -> Sem (Settings : r) [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[exon|tags cmd: #{tagsCmd} #{tagsArgs}|]]
      Left TagsError
_ ->
        [Text] -> Sem (Settings : r) [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  pure (ProjectName -> ProjectRoot -> Maybe ProjectType -> [Text]
formatProject ProjectName
name ProjectRoot
root Maybe ProjectType
tpe [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
tags)

formatMain ::
  Member (Settings !! se) r =>
  Project ->
  Sem r [Text]
formatMain :: forall se (r :: EffectRow).
Member (Settings !! se) r =>
Project -> Sem r [Text]
formatMain (Project ProjectMetadata
meta [ProjectType]
types Maybe ProjectLang
lang [ProjectLang]
langs) = do
  [Text]
metaContent <- ProjectMetadata -> [ProjectLang] -> Sem r [Text]
forall se (r :: EffectRow).
Member (Settings !! se) r =>
ProjectMetadata -> [ProjectLang] -> Sem r [Text]
formatMeta ProjectMetadata
meta [ProjectLang]
langs
  pure $ [Text]
metaContent [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [
    Text
"types: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (ProjectType -> Text
unProjectType (ProjectType -> Text) -> [ProjectType] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProjectType]
types),
    Text
"main language: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe ProjectLang -> Text
formatLang Maybe ProjectLang
lang,
    Text
"languages: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (ProjectLang -> Text
unProjectLang (ProjectLang -> Text) -> [ProjectLang] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProjectLang]
langs)
    ]

formatExtraProjects ::
  Member (Settings !! se) r =>
  [Project] ->
  Sem r [Text]
formatExtraProjects :: forall se (r :: EffectRow).
Member (Settings !! se) r =>
[Project] -> Sem r [Text]
formatExtraProjects [Project]
projects = do
  [[Text]]
formatted <- (Project -> Sem r [Text]) -> [Project] -> Sem r [[Text]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Project -> Sem r [Text]
forall se (r :: EffectRow).
Member (Settings !! se) r =>
Project -> Sem r [Text]
formatMain [Project]
projects
  pure $ [Item [Text]
"", Item [Text]
"Extra projects", Item [Text]
""] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> [[Text]] -> [Text]
forall a. [a] -> [[a]] -> [a]
intercalate [Item [Text]
""] [[Text]]
formatted

formatExtraProjectsIfNonempty ::
  Members [Settings !! se, AtomicState Env] r =>
  Sem r [Text]
formatExtraProjectsIfNonempty :: forall se (r :: EffectRow).
Members '[Settings !! se, AtomicState Env] r =>
Sem r [Text]
formatExtraProjectsIfNonempty = do
  [Project]
projects <- (Env -> [Project]) -> Sem r [Project]
forall s s' (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets Env -> [Project]
Env.projects
  case [Project]
projects of
    Project
_ : [Project]
_ -> [Project] -> Sem r [Text]
forall se (r :: EffectRow).
Member (Settings !! se) r =>
[Project] -> Sem r [Text]
formatExtraProjects [Project]
projects
    [Project]
_ -> [Text] -> Sem r [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

storedError :: StoredReport -> Doc a
storedError :: forall a. StoredReport -> Doc a
storedError (StoredReport (Report Text
_ [Text]
log Severity
_) Time
_) =
  case [Text]
log of
    [] -> Doc a
forall a. Monoid a => a
mempty
    (Text
h : [Text]
t) ->
      Int -> Doc a -> Doc a
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 ([Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vsep (Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc a) -> [Text] -> [Doc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([exon|* #{h}|] Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
t)))

tagErrors :: ReportContext -> [StoredReport] -> Doc a
tagErrors :: forall a. ReportContext -> [StoredReport] -> Doc a
tagErrors ReportContext
ctx [StoredReport]
errs =
  Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty [exon|### #{reportContext ctx}|] Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall ann. Doc ann
line Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vsep (StoredReport -> Doc a
forall a. StoredReport -> Doc a
storedError (StoredReport -> Doc a) -> [StoredReport] -> [Doc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StoredReport]
errs)

errorDiagnostics :: Map ReportContext [StoredReport] -> Doc a
errorDiagnostics :: forall a. Map ReportContext [StoredReport] -> Doc a
errorDiagnostics Map ReportContext [StoredReport]
errs | Map ReportContext [StoredReport] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map ReportContext [StoredReport]
errs =
  Doc a
forall a. Monoid a => a
mempty
errorDiagnostics Map ReportContext [StoredReport]
errs =
  Doc a
"## Reports" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall ann. Doc ann
line Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall ann. Doc ann
line Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vsep ((ReportContext -> [StoredReport] -> Doc a)
-> (ReportContext, [StoredReport]) -> Doc a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ReportContext -> [StoredReport] -> Doc a
forall a. ReportContext -> [StoredReport] -> Doc a
tagErrors ((ReportContext, [StoredReport]) -> Doc a)
-> [(ReportContext, [StoredReport])] -> [Doc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ReportContext [StoredReport]
-> [(ReportContext, [StoredReport])]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map ReportContext [StoredReport]
errs)

diagnostics ::
  Members [Settings !! se, AtomicState Env, Reports] r =>
  Sem r [Text]
diagnostics :: forall se (r :: EffectRow).
Members '[Settings !! se, AtomicState Env, Reports] r =>
Sem r [Text]
diagnostics = do
  [Text]
main <- Project -> Sem r [Text]
forall se (r :: EffectRow).
Member (Settings !! se) r =>
Project -> Sem r [Text]
formatMain (Project -> Sem r [Text]) -> Sem r Project -> Sem r [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env -> Project) -> Sem r Project
forall s s' (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets Env -> Project
Env.mainProject
  [Text]
extra <- Sem r [Text]
forall se (r :: EffectRow).
Members '[Settings !! se, AtomicState Env] r =>
Sem r [Text]
formatExtraProjectsIfNonempty
  [Text]
confLog <- (Env -> [Text]) -> Sem r [Text]
forall s s' (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets Env -> [Text]
Env.configLog
  Doc Any
errors <- Map ReportContext [StoredReport] -> Doc Any
forall a. Map ReportContext [StoredReport] -> Doc a
errorDiagnostics (Map ReportContext [StoredReport] -> Doc Any)
-> Sem r (Map ReportContext [StoredReport]) -> Sem r (Doc Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r (Map ReportContext [StoredReport])
forall (r :: EffectRow).
Member Reports r =>
Sem r (Map ReportContext [StoredReport])
storedReports
  pure $ [Text]
header [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
main [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
extra [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Item [Text]
"", Item [Text]
"loaded config files:"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
confLog [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Text -> [Text]
Text.lines (Doc Any -> Text
forall b a. (Show a, IsString b) => a -> b
show Doc Any
errors)
  where
    header :: [Text]
header =
      [Item [Text]
"Diagnostics", Item [Text]
"", Item [Text]
"Main project", Item [Text]
""]

proDiag ::
  Members [Settings !! se, Scratch !! RpcError, AtomicState Env, Reports] r =>
  Handler r ()
proDiag :: forall se (r :: EffectRow).
Members
  '[Settings !! se, Scratch !! RpcError, AtomicState Env, Reports]
  r =>
Handler r ()
proDiag = do
  forall (eff :: (* -> *) -> * -> *) e (r :: EffectRow) a.
(Reportable e, Members '[eff !! e, Stop Report] r) =>
Sem (eff : r) a -> Sem r a
resumeReport @Scratch do
    [Text]
content <- Sem (Scratch : Stop Report : r) [Text]
forall se (r :: EffectRow).
Members '[Settings !! se, AtomicState Env, Reports] r =>
Sem r [Text]
diagnostics
    Sem (Scratch : Stop Report : r) ScratchState
-> Sem (Scratch : Stop Report : r) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem (Scratch : Stop Report : r) ScratchState
 -> Sem (Scratch : Stop Report : r) ())
-> Sem (Scratch : Stop Report : r) ScratchState
-> Sem (Scratch : Stop Report : r) ()
forall a b. (a -> b) -> a -> b
$ [Text]
-> ScratchOptions -> Sem (Scratch : Stop Report : r) ScratchState
forall (r :: EffectRow) (t :: * -> *).
(Member Scratch r, Foldable t) =>
t Text -> ScratchOptions -> Sem r ScratchState
Scratch.show [Text]
content ScratchOptions
options
  where
    options :: ScratchOptions
options =
      (ScratchId -> ScratchOptions
scratch (Text -> ScratchId
ScratchId Text
name)) {
        $sel:focus:ScratchOptions :: Bool
focus = Bool
True,
        $sel:filetype:ScratchOptions :: Maybe Text
filetype = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name
      }
    name :: Text
name =
      Text
"proteome-diagnostics"