Improve design of detail view (used by "info" & "next" commands)

Author: ad-si

tasklite-core/app/Main.hs

@@ -847,7 +847,7 @@ executeCLiCommand conf now connection cmd =
     Stop ids -> stopTasks conf connection ids
     Prioritize val ids -> adjustPriority conf val ids
     InfoTask idSubstr -> infoTask conf connection idSubstr
-    NextTask -> nextTask connection
+    NextTask -> nextTask conf connection
     FindTask aPattern -> findTask connection aPattern
     AddTag tagText ids -> addTag conf connection tagText ids
     AddNote noteText ids -> addNote conf connection noteText ids

tasklite-core/example-config.yaml

@@ -10,6 +10,9 @@ dueStyle: yellow
 overdueStyle: red
 tagStyle: blue
 utcFormat: YYYY-MM-DD H:MI:S
+#| FIXME: Blocked by https://github.com/vincenthz/hs-hourglass/issue
+# utcFormatShort: YYYY-DDD H:MI
+utcFormatShort: YYYY-MM-DD H:MI
 
 #| Optional, uses the XDG directory per default
 #| https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html

tasklite-core/package.yaml

@@ -61,6 +61,7 @@ default-extensions:
   - LambdaCase
   - MultiParamTypeClasses
   - MultiWayIf
+  - NamedFieldPuns
   - NoImplicitPrelude
   - OverloadedStrings
   - RecordWildCards

tasklite-core/source/Config.hs

@@ -28,6 +28,7 @@ data Config = Config
   , overdueStyle :: AnsiStyle
   , tagStyle :: AnsiStyle
   , utcFormat :: TimeFormatString
+  , utcFormatShort :: TimeFormatString
   , dataDir :: FilePath
   , dbName :: FilePath
   , dateWidth :: Int
@@ -52,6 +53,7 @@ instance FromJSON Config where
     overdueStyle    <- o .:? "overdueStyle" .!= overdueStyle defaultConfig
     tagStyle        <- o .:? "tagStyle" .!= tagStyle defaultConfig
     utcFormat       <- o .:? "utcFormat" .!= utcFormat defaultConfig
+    utcFormatShort  <- o .:? "utcFormatShort" .!= utcFormatShort defaultConfig
     dataDir         <- o .:? "dataDir" .!= dataDir defaultConfig
     dbName          <- o .:? "dbName" .!= dbName defaultConfig
     dateWidth       <- o .:? "dateWidth" .!= dateWidth defaultConfig
@@ -134,6 +136,7 @@ defaultConfig = Config
   , overdueStyle = color Red
   , tagStyle = color Blue
   , utcFormat = toFormat ("YYYY-MM-DD H:MI:S" :: [Char])
+  , utcFormatShort = toFormat ("YYYY-MM-DD H:MI" :: [Char])
   , dataDir = ""
   , dbName = "main.db"
   , dateWidth = 10

tasklite-core/source/Lib.hs

@@ -10,6 +10,7 @@ import Data.Hourglass
 import Data.Text as T
 import Data.ULID
 import Data.Coerce
+import Data.Yaml as Yaml
 import Database.Beam hiding (char)
 import Database.Beam.Sqlite
 import Database.Beam.Schema.Tables
@@ -664,12 +665,152 @@ stopTasks conf connection ids = do
     (show logMessages)
 
 
+formatTaskForInfo
+  :: Config
+  -> DateTime
+  -> (TaskView, [TaskToTag], [TaskToNote])
+  -> Doc AnsiStyle
+formatTaskForInfo conf now (taskV, tags, notes) =
+  let
+    mkGreen = annotate (color Green)
+    grayOut = annotate (colorDull Black)
+    stateHierarchy = getStateHierarchy now $ copyTimesToTask taskV
+    mbCreatedUtc = fmap
+      (pack . (timePrint $ utcFormat defaultConfig))
+      (ulidTextToDateTime $ TaskView.ulid taskV)
+    tagsPretty = tags
+      <&> (\t -> (annotate (tagStyle conf) (pretty $ TaskToTag.tag t))
+                  <++> (fromMaybe mempty $ fmap
+                        (grayOut . pretty . pack . timePrint (utcFormat conf))
+                        (ulidTextToDateTime $ TaskToTag.ulid t))
+                  <++> (grayOut $ pretty $ TaskToTag.ulid t)
+          )
+    notesPretty = notes
+      <&> (\n -> (fromMaybe mempty $ fmap
+                    (grayOut . pretty . pack . timePrint (utcFormat conf))
+                    (ulidTextToDateTime $ TaskToNote.ulid n))
+                  <++> (grayOut $ pretty $ TaskToNote.ulid n) <> hardline
+                  <> (indent 2 $ reflow $ TaskToNote.note n)
+                  <> hardline
+          )
+
+    mbAwakeUtc = TaskView.awake_utc taskV
+    mbReadyUtc = TaskView.ready_utc taskV
+    mbWaitingUtc = TaskView.waiting_utc taskV
+    mbReviewUtc = TaskView.review_utc taskV
+    mbDueUtc = TaskView.due_utc taskV
+    mbClosedUtc = TaskView.closed_utc taskV
+    mbModifiedUtc = Just $ TaskView.modified_utc taskV
+
+    printIf :: Doc AnsiStyle -> Maybe Text -> Maybe (Doc AnsiStyle)
+    printIf name value = fmap
+      (\v -> name <+> (annotate (dueStyle conf) $ pretty v) <> hardline)
+      value
+  in
+       hardline
+    <> annotate bold (reflow $ TaskView.body taskV) <> hardline
+    <> hardline
+    <> (if P.null tags
+        then mempty
+        else (hsep $ (tags <&> TaskToTag.tag) <$$> (formatTag conf)) <> hardline
+              <> hardline
+        )
+
+    <> (if P.null notes
+        then mempty
+        else (notes
+              <&> (\n -> (fromMaybe mempty $ fmap
+                    (grayOut . pretty . pack . timePrint (utcFormatShort conf))
+                    (ulidTextToDateTime $ TaskToNote.ulid n))
+                    <++> (align $ reflow $ TaskToNote.note n)
+                  )
+              & vsep)
+              <> hardline
+              <> hardline
+        )
+
+    <> "   State:" <+> mkGreen (pretty stateHierarchy) <> hardline
+    <> "Priority:" <+> annotate (priorityStyle conf)
+          (pretty $ TaskView.priority taskV) <> hardline
+    <> "    ULID:" <+> grayOut (pretty $ TaskView.ulid taskV)
+        <> hardline
+
+    <> hardline
+
+    <> ((
+          (printIf "🆕  Created  ", mbCreatedUtc) :
+          (printIf "☀️   Awake   ", mbAwakeUtc) :
+          (printIf "📅   Ready   ", mbReadyUtc) :
+          (printIf "⏳  Waiting  ", mbWaitingUtc) :
+          (printIf "🔎  Review   ", mbReviewUtc) :
+          (printIf "📅    Due    ", mbDueUtc) :
+          (printIf "✅   Done    ", mbClosedUtc) :
+          (printIf "✏️   Modified ", mbModifiedUtc) :
+        [])
+        & sortBy (compare `on` snd)
+        <&> (\tup -> (fst tup) (snd tup))
+        & catMaybes
+        & punctuate (pretty ("       ⬇" :: Text))
+        & vsep
+      )
+
+    <> hardline
+
+    <> (fromMaybe mempty $ (fmap
+          (\value -> "Repetition Duration:" <+> (mkGreen $ pretty value)
+              <> hardline)
+          (TaskView.repetition_duration taskV)
+        ))
+
+    <> (fromMaybe mempty $ (fmap
+          (\value -> "Recurrence Duration:" <+> (mkGreen $ pretty value)
+              <> hardline)
+          (TaskView.recurrence_duration taskV)
+        ))
+
+    <> (fromMaybe mempty $ (fmap
+          (\value -> "Group Ulid:"
+              <+> (grayOut $ pretty value)
+              <> hardline)
+          (TaskView.group_ulid taskV)
+        ))
+
+    <> "User:" <+> (mkGreen $ pretty $ TaskView.user taskV) <> hardline
+
+    <> hardline
+
+    <> (fromMaybe mempty $ (fmap
+          (\value -> "Metadata:" <> hardline
+              <> indent 2 (pretty $ decodeUtf8 $ Yaml.encode value)
+              <> hardline
+          )
+          (TaskView.metadata taskV)
+        ))
+
+    <> (if P.null tags
+        then mempty
+        else (annotate underlined "Tags Detailed:") <> hardline
+              <> hardline
+              <> vsep tagsPretty <> hardline
+              <> hardline
+        )
+
+    <> (if P.null notes
+        then mempty
+        else (annotate underlined "Notes Detailed:") <> hardline
+              <> hardline
+              <> vsep notesPretty <> hardline
+        )
+
+
 infoTask :: Config -> Connection -> Text -> IO (Doc AnsiStyle)
 infoTask conf connection idSubstr = do
   execWithTask conf connection idSubstr $ \task -> do
     let
       taskUlid@(TaskUlid idText) = primaryKey task
 
+    now <- dateCurrent
+
     runBeamSqlite connection $ do
       (mbFullTask :: Maybe TaskView) <- runSelectReturningOne $ select $
         filter_ (\tsk -> TaskView.ulid tsk ==. val_ idText) $
@@ -683,39 +824,36 @@ infoTask conf connection idSubstr = do
         filter_ (\theNote -> TaskToNote.task_ulid theNote ==. val_ taskUlid) $
         all_ (_tldbTaskToNote taskLiteDb)
 
-      let
-        -- TODO: Colorize all YAML keys
-        mkGreen = annotate (color Green)
-        yamlList = (hang 2) . ("-" <+>)
-        rmLastLine = unlines . P.reverse . P.drop 1 . P.reverse . lines . show
-        formatTask fullTask =
-          pretty fullTask <> hardline
-          <> mkGreen "priority:"
-              <+> (pretty $ TaskView.priority fullTask)
-              <> hardline
-          <> mkGreen "tags:\n"
-          <> indent 2 (vsep $ fmap
-              (yamlList . pretty . rmLastLine . pretty) tags)
-          <> hardline
-          <> mkGreen "notes:\n"
-          <> indent 2 (vsep $ fmap
-              (yamlList . pretty . rmLastLine . pretty) notes)
-
       pure $ case mbFullTask of
         Nothing -> pretty noTasksWarning
-        Just fullTask -> formatTask fullTask
+        Just fullTask -> formatTaskForInfo conf now (fullTask, tags, notes)
 
 
-nextTask :: Connection -> IO (Doc AnsiStyle)
-nextTask connection = do
-  let
-    stateNullQuery = "select * from `tasks_view` where state is NULL "
-    orderByAndLimit = "order by `priority` desc limit 1"
-  tasks <- query_ connection $ Query $ stateNullQuery <> orderByAndLimit
+nextTask :: Config -> Connection -> IO (Doc AnsiStyle)
+nextTask conf connection = do
+  now <- dateCurrent
+
+  runBeamSqlite connection $ do
+    (mbFullTask :: Maybe TaskView) <- runSelectReturningOne $ select $
+      limit_ 1  $
+      orderBy_ (desc_ . TaskView.priority) $
+      filter_ (\tsk -> TaskView.closed_utc tsk ==. val_ Nothing) $
+      allFromView_ (_tldbTasksView taskLiteDb)
+
+    case mbFullTask of
+      Nothing -> pure $ pretty noTasksWarning
+      Just fullTask -> do
+        tags <- runSelectReturningList $ select $
+          filter_ (\tag -> TaskToTag.task_ulid tag ==.
+            (val_ $ TaskUlid $ TaskView.ulid fullTask)) $
+          all_ (_tldbTaskToTag taskLiteDb)
+
+        notes <- runSelectReturningList $ select $
+          filter_ (\theNote -> TaskToNote.task_ulid theNote ==.
+            (val_ $ TaskUlid $ TaskView.ulid fullTask)) $
+          all_ (_tldbTaskToNote taskLiteDb)
 
-  pure $ case P.head (tasks :: [FullTask]) of
-    Nothing -> pretty noTasksWarning
-    Just task -> pretty task
+        pure $ formatTaskForInfo conf now (fullTask, tags, notes)
 
 
 findTask :: Connection -> Text -> IO (Doc AnsiStyle)
@@ -1098,6 +1236,13 @@ showAtPrecision numOfDigits number =
       else ""
 
 
+formatTag :: Pretty a => Config -> a -> Doc AnsiStyle
+formatTag conf =
+  annotate (tagStyle conf)
+  . (annotate (color Black) "+" <>)
+  . pretty
+
+
 formatTaskLine :: Config -> DateTime -> Int -> FullTask -> Doc AnsiStyle
 formatTaskLine conf now taskUlidWidth task =
   let
@@ -1107,9 +1252,6 @@ formatTaskLine conf now taskUlidWidth task =
       (ulidTextToDateTime $ FullTask.ulid task)
     body = FullTask.body task
     tags = fromMaybe [] $ FullTask.tags task
-    formatTag = annotate (tagStyle conf)
-      . (annotate (color Black) "+" <>)
-      . pretty
     closedUtcMaybe = (FullTask.closed_utc task)
       >>= parseUtc
       <&> timePrint (utcFormat conf)
@@ -1151,7 +1293,7 @@ formatTaskLine conf now taskUlidWidth task =
             else grayOutIfDone (reflow body)) :
         annotate (dueStyle conf) (pretty dueUtcMaybe) :
         annotate (closedStyle conf) (pretty closedUtcMaybe) :
-        hsep (tags <$$> formatTag) :
+        hsep (tags <$$> (formatTag conf)) :
         (if (not $ P.null $ FullTask.notes task) then "📝" else "") :
         [])
   in

tasklite-core/source/Task.hs

@@ -9,6 +9,7 @@ import Protolude as P hiding ((%))
 import Data.Aeson as Aeson
 import Data.Aeson.Text as Aeson
 import qualified Data.HashMap.Lazy as HM
+import Data.Hourglass (DateTime, timePrint)
 import Data.Yaml as Yaml
 import qualified Data.ByteString.Lazy as BSL
 import Data.Csv as Csv
@@ -28,6 +29,8 @@ import Test.QuickCheck
 import Test.QuickCheck.Instances.Text ()
 import Generic.Random
 
+import Config (utcFormat, defaultConfig)
+
 
 -- From https://gist.github.com/chrisdone/7b0c4ebb5b9b94514959206df8992076
 instance Arbitrary Aeson.Value where
@@ -128,6 +131,24 @@ instance Arbitrary DerivedState where
   arbitrary = genericArbitraryU
 
 
+-- | A tuple of (Primary State, Secondary State)
+-- | Check out tasklite.org/concepts for a
+-- | detailed explanation of the different states
+-- | and how they relate to each other
+type StateHierachy = (DerivedState, DerivedState)
+
+instance {-# OVERLAPS #-} Pretty StateHierachy where
+  pretty stateH = (
+    if fst stateH == snd stateH
+    then show $ fst stateH
+    else [fst stateH, snd stateH]
+      <&> show
+      & T.intercalate " and "
+    )
+      & T.replace "Is" ""
+      & pretty
+
+
 textToDerivedState :: Text -> Maybe DerivedState
 textToDerivedState = \case
   "open"      -> Just IsOpen
@@ -169,6 +190,37 @@ derivedStateToQuery = \case
   IsBlocked   -> "" -- TODO
 
 
+getStateHierarchy :: DateTime -> Task -> StateHierachy
+getStateHierarchy now task =
+  let
+    nowTxt = pack $ timePrint (utcFormat defaultConfig) now
+  in
+    case Task.state task of
+      Just Done -> (IsClosed, IsDone)
+      Just Obsolete -> (IsClosed, IsObsolete)
+      Just Deletable -> (IsClosed, IsDeletable)
+      Nothing -> case closed_utc task of
+        Just _ -> (IsClosed, IsClosed)
+        Nothing -> case review_utc task of
+          Just val -> if val > nowTxt
+            then (IsOpen, IsWaiting)
+            else (IsOpen, IsReview)
+          Nothing -> case waiting_utc task of
+            Just _ -> (IsOpen, IsWaiting)
+            Nothing -> case (ready_utc task, awake_utc task) of
+              (Just readyUtc, Just awakeUtc) ->
+                if readyUtc < nowTxt && awakeUtc < nowTxt
+                then (IsOpen, IsReady)
+                else
+                  if readyUtc > nowTxt && awakeUtc < nowTxt
+                  then (IsOpen, IsAwake)
+                  else (IsOpen, IsAsleep)
+              (Just readyUtc, Nothing) | readyUtc < nowTxt -> (IsOpen, IsReady)
+              (Nothing, Just awakeUtc) | awakeUtc < nowTxt -> (IsOpen, IsAwake)
+              (Nothing, Just awakeUtc) | awakeUtc > nowTxt -> (IsOpen, IsAsleep)
+              _ -> (IsOpen, IsOpen)
+
+
 newtype Ulid = Ulid Text
 
 -- | Uses _ to match Beam's defaults