From 1d536c1b2c6e846da9b62e86f9196e0ecd7f877e Mon Sep 17 00:00:00 2001
From: Yvan Sraka <yvan@sraka.xyz>
Date: Mon, 22 May 2023 20:24:31 +0200
Subject: [PATCH] Fix #11: improve parsing

co-authored by @andreabedini
---
 app/Foliage/Meta.hs | 38 +++++++++++++++++++++++++++++++++++++-
 foliage.cabal       |  2 ++
 2 files changed, 39 insertions(+), 1 deletion(-)

diff --git a/app/Foliage/Meta.hs b/app/Foliage/Meta.hs
index 71d7942..f14fae9 100644
--- a/app/Foliage/Meta.hs
+++ b/app/Foliage/Meta.hs
@@ -33,6 +33,8 @@ where
 
 import Control.Applicative ((<|>))
 import Control.Monad (void)
+import Control.Monad.State (modify)
+import Data.HashMap.Strict qualified as HashMap
 import Data.List (sortOn)
 import Data.Maybe (fromMaybe)
 import Data.Ord (Down (Down))
@@ -141,7 +143,7 @@ data PackageVersionSpec = PackageVersionSpec
 sourceMetaCodec :: TomlCodec PackageVersionSpec
 sourceMetaCodec =
   PackageVersionSpec
-    <$> Toml.dioptional (timeCodec "timestamp")
+    <$> optionalTimeCodec "timestamp"
       .= packageVersionTimestamp
     <*> packageSourceCodec
       .= packageVersionSource
@@ -204,3 +206,37 @@ withDefault :: (Eq a) => a -> TomlCodec a -> TomlCodec a
 withDefault d c = (fromMaybe d <$> Toml.dioptional c) .= f
  where
   f a = if a == d then Nothing else Just a
+
+-- | Codec for a maybe-missing time value.
+--
+-- Note this is different from dioptional timeCodec. With dioptional timeCodec,
+-- if the user writes
+--     timestamp = '2022-08-22T10:38:45Z'
+-- rather then
+--     timestamp = 2022-08-22T10:38:45Z
+-- the timestamp will parse as Nothing because it won't match the zoneTime
+-- type and it is not an error because it is optional.
+--
+-- We use a handrolled version of match (matchMaybe) to make it work.
+--
+-- See discussions at
+--  1. https://github.com/input-output-hk/foliage/issues/11
+--  2. https://github.com/input-output-hk/foliage/pull/57
+--  3. https://github.com/kowainik/tomland/issues/223
+optionalTimeCodec :: Toml.Key -> TomlCodec (Maybe UTCTime)
+optionalTimeCodec key =
+  Toml.dimap (fmap $ utcToZonedTime utc) (fmap zonedTimeToUTC) $ matchMaybe Toml._ZonedTime key
+
+matchMaybe :: forall a. Toml.TomlBiMap a Toml.AnyValue -> Toml.Key -> TomlCodec (Maybe a)
+matchMaybe bimap key = Toml.Codec input output
+  where
+    input :: Toml.TomlEnv (Maybe a)
+    input toml = case HashMap.lookup key (Toml.tomlPairs toml) of
+      Nothing -> pure Nothing
+      Just anyVal -> pure <$> Toml.whenLeftBiMapError key (Toml.backward bimap anyVal) pure
+
+    output :: Maybe a -> Toml.TomlState (Maybe a)
+    output Nothing = pure Nothing
+    output (Just a) = do
+      anyVal <- Toml.eitherToTomlState $ Toml.forward bimap a
+      Just a <$ modify (Toml.insertKeyAnyVal key anyVal)
diff --git a/foliage.cabal b/foliage.cabal
index d817eea..1d0f53e 100644
--- a/foliage.cabal
+++ b/foliage.cabal
@@ -57,6 +57,7 @@ executable foliage
         ed25519              >=0.0.5.0    && <0.1,
         filepath             >=1.4.2.1    && <1.5,
         hackage-security     >=0.6.2.1    && <0.7,
+        mtl,
         network-uri          >=2.6.4.1    && <2.7,
         optparse-applicative >=0.17.0.0   && <0.18,
         shake                >=0.19.6     && <0.20,
@@ -66,6 +67,7 @@ executable foliage
         time                 >=1.9.3      && <1.13,
         time-compat          >=1.9.6.1    && <1.10,
         tomland              >=1.3.3.1    && <1.4,
+        unordered-containers,
         vector               >=0.13.0.0   && <0.14,
         with-utf8            >=1.0.2.3    && <1.1,
         zlib                 >=0.6.2.3    && <0.7,