Allow optional time in date metadata field

neuron/neuron.cabal

@@ -1,7 +1,7 @@
 cabal-version: 2.4
 name: neuron
 -- This version must be in sync with what's in Default.dhall
-version: 0.6.3.2
+version: 0.6.4.0
 license: AGPL-3.0-only
 copyright: 2020 Sridhar Ratnakumar
 maintainer: [email protected]
@@ -107,6 +107,7 @@ library
     Data.Graph.Labelled.Type
     Data.Graph.Labelled.Algorithm
     Data.Graph.Labelled.Build
+    Data.Time.DateMayTime
 
 -- A trick to make ghcid reload if library dependencies change
 -- https://haskell.zettel.page/2012605.html

neuron/src/app/Neuron/CLI.hs

@@ -34,7 +34,7 @@ import System.FilePath
 
 run :: (Config -> Action ()) -> IO ()
 run act = do
-  cliParser <- commandParser <$> defaultNotesDir <*> today
+  cliParser <- commandParser <$> defaultNotesDir <*> now
   app <-
     execParser $
       info
@@ -48,9 +48,9 @@ run act = do
         (long "version" <> help "Show version")
     defaultNotesDir =
       (</> "zettelkasten") <$> getHomeDirectory
-    today = do
+    now = do
       tz <- getCurrentTimeZone
-      localDay . utcToLocalTime tz <$> liftIO getCurrentTime
+      utcToLocalTime tz <$> liftIO getCurrentTime
 
 runWith :: (Config -> Action ()) -> App -> IO ()
 runWith act App {..} =

neuron/src/app/Neuron/CLI/New.hs

@@ -15,7 +15,7 @@ import qualified Data.Set as Set
 import Data.Some
 import Data.Text (strip)
 import qualified Data.Text as T
-import Data.Time
+import Data.Time.DateMayTime (DateMayTime, formatDateMayTime)
 import Development.Shake (Action)
 import Neuron.CLI.Types
 import Neuron.Config.Type (Config (..), getZettelFormats)
@@ -24,7 +24,6 @@ import Neuron.Web.Generate as Gen
 import Neuron.Zettelkasten.ID (zettelIDSourceFileName)
 import qualified Neuron.Zettelkasten.ID.Scheme as IDScheme
 import Neuron.Zettelkasten.Zettel (zettelID)
-import Neuron.Zettelkasten.Zettel.Meta (formatZettelDate)
 import Options.Applicative
 import Relude
 import Rib.Shake (ribInputDir)
@@ -56,7 +55,7 @@ newZettelFile NewCommand {..} config = do
       liftIO $ do
         fileAction :: FilePath -> FilePath -> IO () <-
           bool (pure showAction) mkEditActionFromEnv edit
-        writeFileText (notesDir </> zettelFile) $ defaultZettelContent zettelFormat day title
+        writeFileText (notesDir </> zettelFile) $ defaultZettelContent zettelFormat date title
         fileAction notesDir zettelFile
   where
     mkEditActionFromEnv :: IO (FilePath -> FilePath -> IO ())
@@ -83,8 +82,8 @@ newZettelFile NewCommand {..} config = do
           if null v then pure Nothing else pure (Just v)
 
 -- TODO use configurable template files?
-defaultZettelContent :: ZettelFormat -> Day -> Maybe Text -> Text
-defaultZettelContent format day mtitle = case format of
+defaultZettelContent :: ZettelFormat -> DateMayTime -> Maybe Text -> Text
+defaultZettelContent format (formatDateMayTime -> date) mtitle = case format of
   ZettelFormat_Markdown ->
     T.intercalate
       "\n"
@@ -105,6 +104,5 @@ defaultZettelContent format day mtitle = case format of
         "\n"
       ]
   where
-    date = formatZettelDate day
     defaultTitleName = "Zettel created on " <> date
     title = maybe defaultTitleName T.strip mtitle

neuron/src/app/Neuron/CLI/Types.hs

@@ -23,6 +23,13 @@ import Data.Default (def)
 import Data.Some
 import Data.TagTree (mkTagPattern)
 import Data.Time
+import Data.Time.DateMayTime
+  ( DateMayTime,
+    formatDateMayTime,
+    getDay,
+    mkDateMayTime,
+    parseDateMayTime,
+  )
 import Neuron.Reader.Type (ZettelFormat)
 import qualified Neuron.Web.Route as R
 import qualified Neuron.Zettelkasten.Connection as C
@@ -32,7 +39,6 @@ import qualified Neuron.Zettelkasten.Query.Error as Q
 import Neuron.Zettelkasten.Query.Graph as Q
 import qualified Neuron.Zettelkasten.Query.Parser as Q
 import Neuron.Zettelkasten.Zettel as Q
-import Neuron.Zettelkasten.Zettel.Meta (parseZettelDate)
 import Options.Applicative
 import Relude
 import qualified Rib.Cli
@@ -46,7 +52,7 @@ data App = App
 data NewCommand = NewCommand
   { title :: Maybe Text,
     format :: Maybe ZettelFormat,
-    day :: Day,
+    date :: DateMayTime,
     idScheme :: Some IDScheme,
     edit :: Bool
   }
@@ -97,8 +103,8 @@ data RibConfig = RibConfig
   deriving (Eq, Show)
 
 -- | optparse-applicative parser for neuron CLI
-commandParser :: FilePath -> Day -> Parser App
-commandParser defaultNotesDir today = do
+commandParser :: FilePath -> LocalTime -> Parser App
+commandParser defaultNotesDir now = do
   notesDir <-
     option
       Rib.Cli.directoryReader
@@ -127,13 +133,13 @@ commandParser defaultNotesDir today = do
               <> long "format"
               <> help "The document format of the new zettel"
       edit <- switch (long "edit" <> short 'e' <> help "Open the newly-created zettel in $EDITOR")
-      day <-
-        option dayReader $
-          long "day"
-            <> metavar "DAY"
-            <> value today
-            <> showDefault
-            <> help "Zettel creation date in UTC"
+      dateParam <-
+        option dateReader $
+          long "date"
+            <> metavar "DATE/TIME"
+            <> value (mkDateMayTime $ Right now)
+            <> showDefaultWith (toString . formatDateMayTime)
+            <> help "Zettel creation date/time"
       -- NOTE: optparse-applicative picks the first option as the default.
       idSchemeF <-
         fmap
@@ -145,7 +151,7 @@ commandParser defaultNotesDir today = do
           <|> fmap
             (const . Some . IDSchemeCustom)
             (option str (long "id" <> help "Use a custom ID" <> metavar "IDNAME"))
-      pure $ New $ NewCommand title format day (idSchemeF day) edit
+      pure $ New $ NewCommand title format dateParam (idSchemeF $ getDay dateParam) edit
     openCommand = do
       fmap Open $
         fmap
@@ -226,6 +232,6 @@ commandParser defaultNotesDir today = do
           either (Left . toString . Q.showQueryParseError) (maybe (Left "Unsupported query") Right) $ Q.queryFromURI uri
         Left e ->
           Left $ displayException e
-    dayReader :: ReadM Day
-    dayReader =
-      maybeReader (parseZettelDate . toText)
+    dateReader :: ReadM DateMayTime
+    dateReader =
+      maybeReader (parseDateMayTime . toText)

neuron/src/app/Neuron/Reader/Org.hs

@@ -16,9 +16,9 @@ import qualified Data.Map as Map
 import Data.TagTree (Tag (Tag))
 import Data.Tagged
 import Data.Text (toLower)
-import Data.Time.Calendar (Day)
+import Data.Time.DateMayTime (DateMayTime, parseDateMayTime)
 import Neuron.Reader.Type (ZettelParseError, ZettelReader)
-import Neuron.Zettelkasten.Zettel.Meta (Meta (..), parseZettelDate)
+import Neuron.Zettelkasten.Zettel.Meta (Meta (..))
 import Relude
 import Relude.Extra.Map (lookup)
 import Text.Pandoc (def, runPure)
@@ -44,8 +44,7 @@ extractMetadata doc
     pure $ Just Meta {..}
   | otherwise = pure Nothing
   where
-    parseDate :: Text -> Either ZettelParseError Day
-    parseDate date = maybeToRight (Tagged $ "Invalid date format: " <> date) $ parseZettelDate @Maybe date
-
+    parseDate :: Text -> Either ZettelParseError DateMayTime
+    parseDate date = maybeToRight (Tagged $ "Invalid date format: " <> date) $ parseDateMayTime @Maybe date
     parseUnlisted :: Text -> Bool
     parseUnlisted a = toLower a == "true"

neuron/src/app/Neuron/Web/View.hs

@@ -153,7 +153,7 @@ renderSearch graph script = do
       [ "id" .= toJSON zettelID,
         "title" .= zettelTitle,
         "tags" .= zettelTags,
-        "day" .= zettelDay
+        "day" .= zettelDate
       ]
 
 renderBrandFooter :: DomBuilder t m => Maybe Text -> m ()

neuron/src/lib/Data/Time/DateMayTime.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Time.DateMayTime
+  ( -- Date type
+    DateMayTime,
+    mkDateMayTime,
+    getDay,
+    -- Date formatting
+    dateTimeFormat,
+    formatDay,
+    formatLocalTime,
+    formatDateMayTime,
+    -- Date parsing
+    parseDateMayTime
+  )
+where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Time
+import Data.YAML
+import Relude
+
+-- | Like `Day` but with optional time.
+newtype DateMayTime = DateMayTime {unDateMayTime :: (Day, Maybe TimeOfDay)}
+  deriving (Eq, Show, Generic, Ord, ToJSON, FromJSON)
+
+instance FromYAML DateMayTime where
+  parseYAML =
+    parseDateMayTime <=< parseYAML @Text
+
+instance ToYAML DateMayTime where
+  toYAML =
+    toYAML . formatDateMayTime
+
+mkDateMayTime :: Either Day LocalTime -> DateMayTime
+mkDateMayTime =
+  DateMayTime . \case
+    Left day ->
+      (day, Nothing)
+    Right datetime ->
+      localDay &&& Just . localTimeOfDay $ datetime
+
+getDay :: DateMayTime -> Day
+getDay = fst . unDateMayTime
+
+formatDateMayTime :: DateMayTime -> Text
+formatDateMayTime (DateMayTime (day, mtime)) =
+  maybe (formatDay day) (formatLocalTime . LocalTime day) mtime
+
+formatDay :: Day -> Text
+formatDay = formatTime' dateFormat
+
+formatLocalTime :: LocalTime -> Text
+formatLocalTime = formatTime' dateTimeFormat
+
+parseDateMayTime :: (MonadFail m, Alternative m) => Text -> m DateMayTime
+parseDateMayTime (toString -> s) = do
+  fmap mkDateMayTime $
+    fmap Left (parseTimeM False defaultTimeLocale dateFormat s)
+      <|> fmap Right (parseTimeM False defaultTimeLocale dateTimeFormat s)
+
+dateFormat :: String
+dateFormat = "%Y-%m-%d"
+
+dateTimeFormat :: String
+dateTimeFormat = "%Y-%m-%dT%H:%M"
+
+-- | Like `formatTime` but with default time locale and returning Text
+formatTime' :: FormatTime t => String -> t -> Text
+formatTime' s = toText . formatTime defaultTimeLocale s

neuron/src/lib/Neuron/Web/Query/View.hs

@@ -102,7 +102,7 @@ renderZettelLink conn (fromMaybe def -> linkView) Zettel {..} = do
           LinkView_Default ->
             Nothing
           LinkView_ShowDate ->
-            elTime <$> zettelDay
+            elTime <$> zettelDate
           LinkView_ShowID ->
             Just $ el "tt" $ text $ zettelIDText zettelID
       classes :: [Text] = catMaybes $ [Just "zettel-link-container"] <> [connClass, rawClass]

neuron/src/lib/Neuron/Web/Widget.hs

@@ -1,21 +1,21 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Neuron.Web.Widget where
 
 import qualified Data.Text as T
-import Data.Time
-import Neuron.Zettelkasten.Zettel.Meta (formatZettelDate)
+import Data.Time.DateMayTime (DateMayTime, formatDateMayTime, formatDay, getDay)
 import Reflex.Dom.Core
 import Relude
 
 -- | <time> element
-elTime :: DomBuilder t m => Day -> m ()
+elTime :: DomBuilder t m => DateMayTime -> m ()
 elTime t = do
-  let s = formatZettelDate t
   -- cf. https://developer.mozilla.org/en-US/docs/Web/HTML/Element/time#Attributes
-  elAttr "time" ("datetime" =: s) $ text s
+  elAttr "time" ("datetime" =: formatDateMayTime t) $ do
+    text $ formatDay $ getDay t
 
 semanticIcon :: DomBuilder t m => Text -> m ()
 semanticIcon name = elClass "i" (name <> " icon") blank

neuron/src/lib/Neuron/Web/Zettel/View.hs

@@ -119,10 +119,10 @@ renderZettelContent handleLink Zettel {..} = do
     unless zettelTitleInBody $ do
       el "h1" $ text zettelTitle
     void $ elPandoc (Config handleLink) zettelContent
-    whenJust zettelDay $ \day ->
+    whenJust zettelDate $ \date ->
       divClass "metadata" $ do
         elAttr "div" ("class" =: "date" <> "title" =: "Zettel date") $ do
-          elTime day
+          elTime date
 
 renderZettelRawContent :: (DomBuilder t m) => ZettelT Text -> m ()
 renderZettelRawContent Zettel {..} = do

neuron/src/lib/Neuron/Zettelkasten/Query/Parser.hs

@@ -7,11 +7,11 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Neuron.Zettelkasten.Query.Parser
   ( queryFromURI,

neuron/src/lib/Neuron/Zettelkasten/Zettel.hs

@@ -26,7 +26,7 @@ import Data.GADT.Show.TH
 import Data.Graph.Labelled (Vertex (..))
 import Data.Some
 import Data.TagTree (Tag, TagPattern (..))
-import Data.Time.Calendar
+import Data.Time.DateMayTime (DateMayTime)
 import Neuron.Reader.Type
 import Neuron.Zettelkasten.Connection
 import Neuron.Zettelkasten.ID
@@ -55,7 +55,7 @@ data ZettelT content = Zettel
     zettelTitle :: Text,
     zettelTitleInBody :: Bool,
     zettelTags :: [Tag],
-    zettelDay :: Maybe Day,
+    zettelDate :: Maybe DateMayTime,
     zettelUnlisted :: Bool,
     zettelQueries :: [Some ZettelQuery],
     zettelError :: ContentError content,
@@ -118,7 +118,7 @@ instance Vertex (ZettelT c) where
 
 sortZettelsReverseChronological :: [Zettel] -> [Zettel]
 sortZettelsReverseChronological =
-  sortOn (Down . zettelDay)
+  sortOn (Down . zettelDate)
 
 deriveJSONGADT ''ZettelQuery