diff --git a/neuron/neuron.cabal b/neuron/neuron.cabal index 0e535a3a8..2fc96c480 100644 --- a/neuron/neuron.cabal +++ b/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: srid@srid.ca @@ -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 diff --git a/neuron/src/app/Neuron/CLI.hs b/neuron/src/app/Neuron/CLI.hs index f4308fd7b..98c0b71de 100644 --- a/neuron/src/app/Neuron/CLI.hs +++ b/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 {..} = diff --git a/neuron/src/app/Neuron/CLI/New.hs b/neuron/src/app/Neuron/CLI/New.hs index 35e8a365d..f0403a9a6 100644 --- a/neuron/src/app/Neuron/CLI/New.hs +++ b/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 diff --git a/neuron/src/app/Neuron/CLI/Types.hs b/neuron/src/app/Neuron/CLI/Types.hs index 6db648b77..e694753c2 100644 --- a/neuron/src/app/Neuron/CLI/Types.hs +++ b/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) diff --git a/neuron/src/app/Neuron/Reader/Org.hs b/neuron/src/app/Neuron/Reader/Org.hs index afbcccf24..24e495ac5 100644 --- a/neuron/src/app/Neuron/Reader/Org.hs +++ b/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" diff --git a/neuron/src/app/Neuron/Web/View.hs b/neuron/src/app/Neuron/Web/View.hs index 44d08b3a8..ac82d5b01 100644 --- a/neuron/src/app/Neuron/Web/View.hs +++ b/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 () diff --git a/neuron/src/lib/Data/Time/DateMayTime.hs b/neuron/src/lib/Data/Time/DateMayTime.hs new file mode 100644 index 000000000..a4d803665 --- /dev/null +++ b/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 diff --git a/neuron/src/lib/Neuron/Web/Query/View.hs b/neuron/src/lib/Neuron/Web/Query/View.hs index cbab65dd5..3fea82f3a 100644 --- a/neuron/src/lib/Neuron/Web/Query/View.hs +++ b/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] diff --git a/neuron/src/lib/Neuron/Web/Widget.hs b/neuron/src/lib/Neuron/Web/Widget.hs index a4847c8cd..c17f82c3e 100644 --- a/neuron/src/lib/Neuron/Web/Widget.hs +++ b/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 -- |