Allow optional time in date metadata field

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

@@ -15,7 +15,6 @@ import qualified Data.Set as Set
 import Data.Some
 import Data.Text (strip)
 import qualified Data.Text as T
-import Data.Time
 import Development.Shake (Action)
 import Neuron.CLI.Types
 import Neuron.Config.Type (Config (..), getZettelFormats)
@@ -24,7 +23,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 +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 dmt mtitle = case format of
   ZettelFormat_Markdown ->
     T.intercalate
       "\n"
@@ -105,6 +104,6 @@ defaultZettelContent format day mtitle = case format of
         "\n"
       ]
   where
-    date = formatZettelDate day
+    date = formatZettelDate dmt
     defaultTitleName = "Zettel created on " <> date
     title = maybe defaultTitleName T.strip mtitle

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 (DateMayTime, formatZettelDate, parseZettelDate)
 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,
+    date :: DateMayTime,
     idScheme :: Some IDScheme,
     edit :: Bool
   }
@@ -127,13 +127,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"
+            <> value (Left today)
+            <> showDefaultWith (toString . formatZettelDate)
+            <> help "Zettel creation date/time"
       -- NOTE: optparse-applicative picks the first option as the default.
       idSchemeF <-
         fmap
@@ -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 dateParam (idSchemeF $ extractDay dateParam) edit
     openCommand = do
       fmap Open $
         fmap
@@ -226,6 +226,11 @@ 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 =
+    dateReader :: ReadM DateMayTime
+    dateReader =
       maybeReader (parseZettelDate . toText)
+    extractDay :: DateMayTime -> Day
+    extractDay dmt =
+      case dmt of
+        Left day -> day
+        Right lt -> localDay lt

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,14 +1,21 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Neuron.Zettelkasten.Zettel.Meta
   ( Meta (..),
+    dateTimeFormat,
     formatZettelDate,
+    formatZettelDateAsDay,
     parseZettelDate,
+    parseZettelDay,
+    DateMayTime,
   )
 where
 
@@ -17,12 +24,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 +57,36 @@ instance FromYAML Meta where
 --         "date" .= date
 --       ]
 
-instance FromYAML Day where
+instance FromYAML DateMayTime where
   parseYAML =
     parseZettelDate <=< parseYAML @Text
 
-instance ToYAML Day where
+instance ToYAML DateMayTime 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 . formatTime defaultTimeLocale dateFormat . \case
+    Left day -> day
+    Right localtime -> localDay localtime
+
+parseZettelDate :: (MonadFail m, Alternative m) => Text -> m DateMayTime
+parseZettelDate (toString -> s) =
+  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

@@ -37,14 +37,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 $ Left v
             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,33 @@
+{-# 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
+  let itParsesDay name s =
+        it name $ do
+          parseDate s `shouldBe` Right (Left (ModifiedJulianDay 59077))
+      itParsesDate name s =
+        it name $ do
+          parseDate s `shouldBe` Right (Right (LocalTime (ModifiedJulianDay 59077) (TimeOfDay 9 42 0)))
+      itParsesInvalid name s =
+        it name $ do
+          parseDate s `shouldBe` Left (Tagged $ "Invalid date format: " <> s)
+
+  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"