{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use uncurry" #-}
{-|
Datatype to represent a task as stored in the `tasks` table
-}
module Task where
import Protolude (
Applicative ((<*>)),
Either (Left, Right),
Enum (toEnum),
Eq ((==)),
Float,
Functor (fmap),
Generic,
Hashable,
Maybe (..),
Ord ((<), (>)),
Read,
Semigroup ((<>)),
Show,
decodeUtf8,
fst,
otherwise,
pure,
show,
snd,
($),
(&),
(&&),
(.),
(<$>),
(<&>),
)
import Protolude qualified as P
import Data.Aeson as Aeson (
FromJSON,
ToJSON,
Value (Object),
eitherDecodeStrictText,
encode,
)
import Data.Aeson.Key as Key (fromText)
import Data.Aeson.KeyMap as KeyMap (fromList, insert)
import Data.ByteString.Lazy qualified as BSL
import Data.Csv qualified as Csv
import Data.Generics (Data)
import Data.Hourglass (DateTime, timePrint)
import Data.Text (Text, pack)
import Data.Text qualified as T
import Data.Yaml as Yaml (encode)
import Database.SQLite.Simple as Sql (
FromRow (..),
ResultError (ConversionFailed),
SQLData (SQLText),
ToRow (toRow),
field,
)
import Database.SQLite.Simple.FromField as Sql.FromField (
FromField (..),
returnError,
)
import Database.SQLite.Simple.Internal (Field (Field))
import Database.SQLite.Simple.Ok (Ok (Ok))
import Database.SQLite.Simple.ToField as Sql.ToField (ToField (..), toField)
import Generic.Random (genericArbitrary, genericArbitraryU, (%))
import Prettyprinter (Pretty (pretty))
import Test.QuickCheck (Arbitrary (arbitrary))
import Test.QuickCheck.Instances.Text ()
import Config (defaultConfig, utcFormat)
import Control.Arrow ((>>>))
import Database.SQLite.Simple (
Connection,
Only (Only),
SQLData (SQLNull),
query,
)
import Database.SQLite.Simple.QQ (sql)
data TaskState
= Done
| Obsolete
| Deletable
deriving (Eq, Enum, Generic, Ord, Read, Show, Data)
instance Arbitrary TaskState where
arbitrary = genericArbitrary (4 % 2 % 1 % ())
instance Sql.FromField.FromField TaskState where
fromField f@(Field (SQLText txt) _) =
case textToTaskState txt of
Just val -> Ok val
Nothing ->
returnError ConversionFailed f $
T.unpack $
"expecting a valid TaskState and not \"" <> txt <> "\""
fromField f =
returnError ConversionFailed f "expecting SQLText column type"
instance Sql.ToField.ToField TaskState where
toField = SQLText . show
instance FromJSON TaskState
instance ToJSON TaskState
instance Csv.ToRecord TaskState
instance Csv.ToNamedRecord TaskState
instance Csv.ToField TaskState where
toField = show
instance Hashable TaskState
stateDefault :: TaskState
stateDefault = toEnum 0
stateOptions :: Text
stateOptions =
T.intercalate "," $
fmap (("'" <>) . (<> "'") . show) [stateDefault ..]
textToTaskState :: Text -> Maybe TaskState
textToTaskState txt =
let
func t
| t `P.elem` ["done", "completed", "finished", "fixed"] = Just Done
| t `P.elem` ["obsolete"] = Just Obsolete
| t
`P.elem` [ "deletable"
, "deleted"
, "removable"
, "removed"
] =
Just Deletable
| otherwise = Nothing
txtLower = T.toLower txt
in
func txtLower
data DerivedState
= IsOpen
| IsClosed
| IsAsleep
| IsAwake
| IsReady
| IsWaiting
| IsReview
| IsDone
| IsObsolete
| IsDeletable
| IsBlocked
deriving (Eq, Generic, Show)
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 StateHierarchy = (DerivedState, DerivedState)
instance {-# OVERLAPS #-} Pretty StateHierarchy 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 =
T.toLower >>> \case
"open" -> Just IsOpen
"closed" -> Just IsClosed
"asleep" -> Just IsAsleep
"awake" -> Just IsAwake
"ready" -> Just IsReady
"waiting" -> Just IsWaiting
"review" -> Just IsReview
"done" -> Just IsDone
"obsolete" -> Just IsObsolete
"deletable" -> Just IsDeletable
"blocked" -> Just IsBlocked
_ -> Nothing
derivedStateToQuery :: DerivedState -> Text
derivedStateToQuery = \case
IsOpen -> "closed_utc is null"
IsClosed -> "closed_utc is not null"
IsAsleep ->
"awake_utc > datetime('now') and \
\(ready_utc is null or ready_utc > datetime('now')) \
\and closed_utc is null"
IsAwake ->
"awake_utc < datetime('now') and \
\(ready_utc is null or ready_utc > datetime('now')) \
\and closed_utc is null"
IsReady ->
"(awake_utc is null or awake_utc < datetime('now')) \
\and ready_utc < datetime('now') \
\and closed_utc is null"
IsWaiting ->
"waiting_utc is not null and \
\(review_utc is null or review_utc > datetime('now')) \
\and closed_utc is null"
IsReview ->
"waiting_utc is not null and \
\(review_utc is null or review_utc < datetime('now')) \
\and closed_utc is null"
IsDone -> "closed_utc is not null and state is 'Done'"
IsObsolete -> "closed_utc is not null and state is 'Obsolete'"
IsDeletable -> "closed_utc is not null and state is 'Deletable'"
IsBlocked -> "" -- TODO
getStateHierarchy :: DateTime -> Task -> StateHierarchy
getStateHierarchy now task = do
let
nowTxt = pack $ timePrint (utcFormat defaultConfig) now
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
data Task = Task
{ ulid :: Text -- TODO: Use Ulid type
, body :: Text
, modified_utc :: Text
, awake_utc :: Maybe Text
, ready_utc :: Maybe Text
, waiting_utc :: Maybe Text
, review_utc :: Maybe Text
, due_utc :: Maybe Text
, closed_utc :: Maybe Text
, state :: Maybe TaskState
, group_ulid :: Maybe Text
, repetition_duration :: Maybe Text
, recurrence_duration :: Maybe Text
, priority_adjustment :: Maybe Float
, user :: Text
, metadata :: Maybe Aeson.Value
}
deriving (Generic, Data, Show, Eq)
-- For conversion from SQLite with SQLite.Simple
instance FromRow Task where
fromRow =
Task
<$> field
<*> field
<*> field
<*> field
<*> field
<*> field
<*> field
<*> field
<*> field
<*> field
<*> field
<*> field
<*> field
<*> field
<*> field
<*> ( field <&> \case
Just (Object obj) -> Just $ Object obj
_ -> Nothing
)
instance ToRow Task where
toRow task =
[ Sql.ToField.toField task.ulid
, Sql.ToField.toField task.body
, Sql.ToField.toField task.modified_utc
, Sql.ToField.toField task.awake_utc
, Sql.ToField.toField task.ready_utc
, Sql.ToField.toField task.waiting_utc
, Sql.ToField.toField task.review_utc
, Sql.ToField.toField task.due_utc
, Sql.ToField.toField task.closed_utc
, Sql.ToField.toField task.state
, Sql.ToField.toField task.group_ulid
, Sql.ToField.toField task.repetition_duration
, Sql.ToField.toField task.recurrence_duration
, Sql.ToField.toField task.priority_adjustment
, Sql.ToField.toField task.user
, case task.metadata of
Nothing -> SQLNull
Just val -> SQLText $ val & (Aeson.encode >>> BSL.toStrict >>> decodeUtf8)
]
instance Hashable Task
instance Sql.FromField.FromField Value where
fromField aField@(Field (SQLText txt) _) =
case eitherDecodeStrictText txt of
Left error -> returnError ConversionFailed aField error
Right value -> Ok value
fromField f = returnError ConversionFailed f "expecting SQLText column type"
-- For conversion to JSON
instance ToJSON Task
instance Pretty Task where
pretty =
pretty
. T.dropEnd 1 -- Drop trailing newline to maybe add it later
. decodeUtf8
. Yaml.encode
instance Arbitrary Task where
arbitrary = genericArbitraryU
emptyTask :: Task
emptyTask =
Task
{ ulid = ""
, body = ""
, modified_utc = ""
, awake_utc = Nothing
, ready_utc = Nothing
, waiting_utc = Nothing
, review_utc = Nothing
, due_utc = Nothing
, closed_utc = Nothing
, state = Nothing
, group_ulid = Nothing
, repetition_duration = Nothing
, recurrence_duration = Nothing
, priority_adjustment = Nothing
, user = ""
, metadata = Nothing
}
setMetadataField :: Text -> Value -> Task -> Task
setMetadataField fieldNameText value task =
task
{ metadata =
case metadata task of
Just (Object obj) ->
Just $ Object $ KeyMap.insert (Key.fromText fieldNameText) value obj
Nothing ->
Just $ Object $ fromList [(Key.fromText fieldNameText, value)]
_ -> metadata task
}
{-| Convert a task to a Markdown string with YAML frontmatter that can be edited
| and then converted back to a task.
| Tags and notes are commented out, so they are not accidentally added again.
-}
taskToEditableMarkdown :: Connection -> Task -> P.IO P.ByteString
taskToEditableMarkdown conn task = do
(tags :: [[P.Text]]) <-
if T.null task.ulid
then pure []
else
query
conn
[sql|
SELECT tag
FROM task_to_tag
WHERE task_ulid == ?
|]
(Only task.ulid)
(notes :: [[P.Text]]) <-
if T.null task.ulid
then pure []
else
query
conn
[sql|
SELECT note
FROM task_to_note
WHERE task_ulid == ?
|]
(Only task.ulid)
let
indentNoteContent noteContent =
noteContent
& T.strip
& T.lines
<&> T.stripEnd
& T.intercalate "\n# "
taskWithEmptyBody = task{body = ""}
frontmatterYaml =
( taskWithEmptyBody
& Yaml.encode
& P.decodeUtf8
& T.replace "\nbody: ''\n" "\n"
)
<> "\n# | Existing tags and notes can't be edited here, \
\but new ones can be added\n\n"
<> (("# tags: " :: Text) <> P.show (P.concat tags) <> "\n")
<> "tags: []\n"
<> ( ("\n# notes:\n" :: Text)
<> ( notes
& P.concat
<&> (\note -> "# - " <> indentNoteContent note)
& T.unlines
)
)
<> "notes: []\n"
pure $
("---\n" <> frontmatterYaml <> "...\n\n" <> body task)
& P.encodeUtf8