Allow optional time in date metadata field

neuron/src/app/Neuron/CLI.hs

@@ -50,7 +50,7 @@ run act = do
       (</> "zettelkasten") <$> getHomeDirectory
     today = 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

@@ -24,7 +24,7 @@ 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 Neuron.Zettelkasten.Zettel.Meta
 import Options.Applicative
 import Relude
 import Rib.Shake (ribInputDir)
@@ -56,7 +56,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 localtime title
         fileAction notesDir zettelFile
   where
     mkEditActionFromEnv :: IO (FilePath -> FilePath -> IO ())
@@ -83,8 +83,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 -> LocalTime -> Maybe Text -> Text
+defaultZettelContent format now mtitle = case format of
   ZettelFormat_Markdown ->
     T.intercalate
       "\n"
@@ -105,6 +105,10 @@ defaultZettelContent format day mtitle = case format of
         "\n"
       ]
   where
-    date = formatZettelDate day
+    date = formatZettelLocalTime now
     defaultTitleName = "Zettel created on " <> date
     title = maybe defaultTitleName T.strip mtitle
+
+formatZettelLocalTime :: LocalTime -> Text
+formatZettelLocalTime =
+  toText . formatTime defaultTimeLocale dateTimeFormat

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

@@ -32,7 +32,7 @@ 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 Neuron.Zettelkasten.Zettel.Meta (parseZettelDay)
 import Options.Applicative
 import Relude
 import qualified Rib.Cli
@@ -46,7 +46,7 @@ data App = App
 data NewCommand = NewCommand
   { title :: Maybe Text,
     format :: Maybe ZettelFormat,
-    day :: Day,
+    localtime :: LocalTime,
     idScheme :: Some IDScheme,
     edit :: Bool
   }
@@ -97,8 +97,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
@@ -131,7 +131,7 @@ commandParser defaultNotesDir today = do
         option dayReader $
           long "day"
             <> metavar "DAY"
-            <> value today
+            <> value (localDay now)
             <> showDefault
             <> help "Zettel creation date in UTC"
       -- NOTE: optparse-applicative picks the first option as the default.
@@ -145,7 +145,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 now (idSchemeF day) edit
     openCommand = do
       fmap Open $
         fmap
@@ -228,4 +228,4 @@ commandParser defaultNotesDir today = do
           Left $ displayException e
     dayReader :: ReadM Day
     dayReader =
-      maybeReader (parseZettelDate . toText)
+      maybeReader (parseZettelDay . toText)

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

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

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/Neuron/Web/Query/View.hs

@@ -34,6 +34,7 @@ import Neuron.Zettelkasten.Connection
 import Neuron.Zettelkasten.ID
 import Neuron.Zettelkasten.Query.Theme (LinkView (..), ZettelsView (..))
 import Neuron.Zettelkasten.Zettel
+import Neuron.Zettelkasten.Zettel.Meta (formatZettelDateAsDay)
 import Reflex.Dom.Core hiding (count, tag)
 import Relude
 
@@ -104,7 +105,7 @@ renderZettelLink conn (fromMaybe def -> linkView) Zettel {..} = do
           LinkView_Default ->
             Nothing
           LinkView_ShowDate ->
-            elTime <$> zettelDay
+            elTime . formatZettelDateAsDay <$> 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

@@ -5,17 +5,14 @@
 module Neuron.Web.Widget where
 
 import qualified Data.Text as T
-import Data.Time
-import Neuron.Zettelkasten.Zettel.Meta (formatZettelDate)
 import Reflex.Dom.Core
 import Relude
 
 -- | <time> element
-elTime :: DomBuilder t m => Day -> m ()
+elTime :: DomBuilder t m => Text -> 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" =: t) $ text t
 
 semanticIcon :: DomBuilder t m => Text -> m ()
 semanticIcon name = elClass "i" (name <> " icon") blank

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

@@ -28,6 +28,7 @@ import qualified Neuron.Zettelkasten.Graph as G
 import Neuron.Zettelkasten.Query.Error (QueryError, showQueryError)
 import qualified Neuron.Zettelkasten.Query.Eval as Q
 import Neuron.Zettelkasten.Zettel
+import Neuron.Zettelkasten.Zettel.Meta (formatZettelDate)
 import Reflex.Dom.Core hiding ((&))
 import Reflex.Dom.Pandoc
 import Relude hiding ((&))
@@ -119,10 +120,10 @@ renderZettelContent handleLink Zettel {..} = do
     unless zettelTitleInBody $ do
       el "h1" $ text zettelTitle
     void $ elPandoc (Config handleLink) zettelContent
-    whenJust zettelDay $ \day ->
+    whenJust zettelDate $ \day ->
       divClass "metadata" $ do
         elAttr "div" ("class" =: "date" <> "title" =: "Zettel date") $ do
-          elTime day
+          elTime $ formatZettelDate day
 
 renderZettelRawContent :: (DomBuilder t m) => ZettelT Text -> m ()
 renderZettelRawContent Zettel {..} = do

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

@@ -26,12 +26,12 @@ import Data.GADT.Show.TH
 import Data.Graph.Labelled (Vertex (..))
 import Data.Some
 import Data.TagTree (Tag, TagPattern (..))
-import Data.Time.Calendar
 import Neuron.Reader.Type
 import Neuron.Zettelkasten.Connection
 import Neuron.Zettelkasten.ID
 import Neuron.Zettelkasten.Query.Error
 import Neuron.Zettelkasten.Query.Theme
+import Neuron.Zettelkasten.Zettel.Meta (DateMayTime)
 import Relude hiding (show)
 import Text.Pandoc.Definition (Pandoc (..))
 import Text.Show (Show (show))
@@ -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
 

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

@@ -1,4 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
@@ -7,8 +9,12 @@
 
 module Neuron.Zettelkasten.Zettel.Meta
   ( Meta (..),
+    dateTimeFormat,
     formatZettelDate,
+    formatZettelDateAsDay,
     parseZettelDate,
+    parseZettelDay,
+    DateMayTime,
   )
 where
 
@@ -17,12 +23,14 @@ import Data.Time
 import Data.YAML
 import Relude
 
+type DateMayTime = Either Day LocalTime
+
 -- | YAML metadata in a zettel markdown file
 data Meta = Meta
   { title :: Maybe Text,
     tags :: Maybe [Tag],
     -- | Creation day
-    date :: Maybe Day,
+    date :: Maybe DateMayTime,
     -- | List in the z-index
     unlisted :: Maybe Bool
   }
@@ -48,22 +56,39 @@ instance FromYAML Meta where
 --         "date" .= date
 --       ]
 
-instance FromYAML Day where
+instance FromYAML (Either Day LocalTime) where
   parseYAML =
     parseZettelDate <=< parseYAML @Text
 
-instance ToYAML Day where
+instance ToYAML (Either Day LocalTime) where
   toYAML =
     toYAML . formatZettelDate
 
--- | The format in which we decode and encode zettel dates.
-zettelDateFormat :: String
-zettelDateFormat = "%Y-%m-%d"
-
-formatZettelDate :: Day -> Text
+formatZettelDate :: DateMayTime -> Text
 formatZettelDate =
-  toText . formatTime defaultTimeLocale zettelDateFormat
+  toText . \case
+    Left day -> formatTime defaultTimeLocale dateFormat day
+    Right localtime -> formatTime defaultTimeLocale dateTimeFormat localtime
+
+formatZettelDateAsDay :: DateMayTime -> Text
+formatZettelDateAsDay =
+  toText . \case
+    Left day -> fmt day
+    Right localtime -> fmt (localDay localtime)
+  where
+    fmt = formatTime defaultTimeLocale dateFormat
+
+parseZettelDate :: (MonadFail m, Alternative m) => Text -> m DateMayTime
+parseZettelDate t =
+  let s = toString t
+   in Left <$> parseTimeM False defaultTimeLocale dateFormat s <|> Right <$> parseTimeM False defaultTimeLocale dateTimeFormat s
+
+parseZettelDay :: MonadFail m => Text -> m Day
+parseZettelDay =
+  parseTimeM False defaultTimeLocale dateFormat . toString
+
+dateFormat :: String
+dateFormat = "%Y-%m-%d"
 
-parseZettelDate :: MonadFail m => Text -> m Day
-parseZettelDate =
-  parseTimeM False defaultTimeLocale zettelDateFormat . toString
+dateTimeFormat :: String
+dateTimeFormat = "%Y-%m-%dT%H:%M"

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

@@ -8,6 +8,7 @@ module Neuron.Zettelkasten.Zettel.Parser where
 import Control.Monad.Writer
 import Data.Some
 import qualified Data.Text as T
+import Data.Time.LocalTime (LocalTime (LocalTime), midday)
 import Neuron.Reader.Type
 import Neuron.Zettelkasten.ID
 import Neuron.Zettelkasten.Query.Error
@@ -37,14 +38,14 @@ parseZettel format zreader fn zid s = do
               ((,True) . plainify . snd <$> getH1 doc)
                 <|> ((,False) . takeInitial . plainify <$> getFirstParagraphText doc)
           tags = fromMaybe [] $ Meta.tags =<< meta
-          day = case zid of
+          date = case zid of
             -- We ignore the "data" meta field on legacy Date IDs, which encode the
             -- creation date in the ID.
-            ZettelDateID v _ -> Just v
+            ZettelDateID v _ -> Just (Right $ LocalTime v midday)
             ZettelCustomID _ -> Meta.date =<< meta
           unlisted = fromMaybe False $ Meta.unlisted =<< meta
           (queries, errors) = runWriter $ extractQueries doc
-       in Right $ Zettel zid format fn title titleInBody tags day unlisted queries errors doc
+       in Right $ Zettel zid format fn title titleInBody tags date unlisted queries errors doc
   where
     -- Extract all (valid) queries from the Pandoc document
     extractQueries :: MonadWriter [QueryParseError] m => Pandoc -> m [Some ZettelQuery]

neuron/test/Neuron/Reader/OrgSpec.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Neuron.Reader.OrgSpec
+  ( spec,
+  )
+where
+
+import Data.Tagged (Tagged (Tagged))
+import Data.Time (LocalTime (LocalTime))
+import Data.Time.Calendar
+import Data.Time.LocalTime (TimeOfDay (TimeOfDay))
+import Neuron.Reader.Org
+import Relude
+import Test.Hspec
+
+spec :: Spec
+spec = do
+  describe "date-tag parsing" $ do
+    itParsesDay "with day" "2020-08-16"
+    itParsesDate "with localtime" "2020-08-16T09:42"
+    itParsesInvalid "with invalid" "2020-08-16 09:42"
+
+itParsesDay :: String -> Text -> SpecWith ()
+itParsesDay name s =
+  it name $ do
+    parseDate s `shouldBe` Right (Left (ModifiedJulianDay 59077))
+
+itParsesDate :: String -> Text -> SpecWith ()
+itParsesDate name s =
+  it name $ do
+    parseDate s `shouldBe` Right (Right (LocalTime (ModifiedJulianDay 59077) (TimeOfDay 9 42 0)))
+
+itParsesInvalid :: String -> Text -> SpecWith ()
+itParsesInvalid name s =
+  it name $ do
+    parseDate s `shouldBe` Left (Tagged $ "Invalid date format: " <> s)