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
-      utcToLocalTime tz <$> liftIO getCurrentTime
+      localDay . utcToLocalTime tz <$> liftIO getCurrentTime
 
 runWith :: (Config -> Action ()) -> App -> IO ()
 runWith act App {..} =

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

@@ -56,7 +56,7 @@ newZettelFile NewCommand {..} config = do
       liftIO $ do
         fileAction :: FilePath -> FilePath -> IO () <-
           bool (pure showAction) mkEditActionFromEnv edit
-        writeFileText (notesDir </> zettelFile) $ defaultZettelContent zettelFormat localtime title
+        writeFileText (notesDir </> zettelFile) $ defaultZettelContent zettelFormat date title
         fileAction notesDir zettelFile
   where
     mkEditActionFromEnv :: IO (FilePath -> FilePath -> IO ())

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

@@ -46,7 +46,7 @@ data App = App
 data NewCommand = NewCommand
   { title :: Maybe Text,
     format :: Maybe ZettelFormat,
-    localtime :: LocalTime,
+    date :: LocalTime,
     idScheme :: Some IDScheme,
     edit :: Bool
   }
@@ -97,8 +97,8 @@ data RibConfig = RibConfig
   deriving (Eq, Show)
 
 -- | optparse-applicative parser for neuron CLI
-commandParser :: FilePath -> LocalTime -> Parser App
-commandParser defaultNotesDir now = do
+commandParser :: FilePath -> Day -> Parser App
+commandParser defaultNotesDir today = do
   notesDir <-
     option
       Rib.Cli.directoryReader
@@ -127,11 +127,11 @@ commandParser defaultNotesDir now = 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 <-
+      dayParam <-
         option dayReader $
           long "day"
             <> metavar "DAY"
-            <> value (localDay now)
+            <> value today
             <> showDefault
             <> help "Zettel creation date in UTC"
       -- NOTE: optparse-applicative picks the first option as the default.
@@ -145,7 +145,7 @@ commandParser defaultNotesDir now = do
           <|> fmap
             (const . Some . IDSchemeCustom)
             (option str (long "id" <> help "Use a custom ID" <> metavar "IDNAME"))
-      pure $ New $ NewCommand title format now (idSchemeF day) edit
+      pure $ New $ NewCommand title format (LocalTime dayParam midday) (idSchemeF dayParam) edit
     openCommand = do
       fmap Open $
         fmap

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -56,11 +57,11 @@ instance FromYAML Meta where
 --         "date" .= date
 --       ]
 
-instance FromYAML (Either Day LocalTime) where
+instance FromYAML DateMayTime where
   parseYAML =
     parseZettelDate <=< parseYAML @Text
 
-instance ToYAML (Either Day LocalTime) where
+instance ToYAML DateMayTime where
   toYAML =
     toYAML . formatZettelDate
 
@@ -72,16 +73,13 @@ formatZettelDate =
 
 formatZettelDateAsDay :: DateMayTime -> Text
 formatZettelDateAsDay =
-  toText . \case
-    Left day -> fmt day
-    Right localtime -> fmt (localDay localtime)
-  where
-    fmt = formatTime defaultTimeLocale dateFormat
+  toText . formatTime defaultTimeLocale dateFormat . \case
+    Left day -> day
+    Right localtime -> localDay localtime
 
 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
+parseZettelDate (toString -> s) =
+  Left <$> parseTimeM False defaultTimeLocale dateFormat s <|> Right <$> parseTimeM False defaultTimeLocale dateTimeFormat s
 
 parseZettelDay :: MonadFail m => Text -> m Day
 parseZettelDay =

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

@@ -8,7 +8,6 @@ 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
@@ -41,7 +40,7 @@ parseZettel format zreader fn zid s = do
           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 (Right $ LocalTime v midday)
+            ZettelDateID v _ -> Just $ Left v
             ZettelCustomID _ -> Meta.date =<< meta
           unlisted = fromMaybe False $ Meta.unlisted =<< meta
           (queries, errors) = runWriter $ extractQueries doc

neuron/test/Neuron/Reader/OrgSpec.hs

@@ -17,22 +17,17 @@ 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"
-
-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)

neuron/test/Neuron/Zettelkasten/ZettelSpec.hs

@@ -27,7 +27,7 @@ spec = do
   describe "sortZettelsReverseChronological" $ do
     let mkDay = fromGregorian 2020 3
         mkZettelDay = Just . Left . mkDay
-        mkZettelLocalTime day hh mm = (Just (Right $ (LocalTime (mkDay day) (TimeOfDay hh mm 0))))
+        mkZettelLocalTime day hh mm = Just $ Right $ LocalTime (mkDay day) $ TimeOfDay hh mm 0
 
         (_ :: Maybe Meta, _dummyContent) = either (error . show) id $ parseMarkdown "<spec>" "Dummy"
 
@@ -56,6 +56,6 @@ spec = do
         `shouldBe` reverse zs
 
     it "sorts correctly with mixed dates" $ do
-      let zs = [mkZettel 3 (mkZettelDay 3) 2, mkZettel 3 (mkZettelLocalTime 3 0 0) 1]
+      let zs = [mkZettel 3 (mkZettelDay 5) 2, mkZettel 3 (mkZettelLocalTime 3 0 0) 1]
       sortZettelsReverseChronological zs
         `shouldBe` reverse zs