Skip to content

Commit

Permalink
Preserve even weirder Depends behavior
Browse files Browse the repository at this point in the history
It seems the `Depends` _key_ is indeed required, but a `Null` as the
_value_ is acceptable (and defaulted to no dependencies). I don't know
if we need to preserve this too, but the tests fail if we don't.

It was super fun to see one test assert it was optional and fail, only
to have the test that asserts it as required then fail (:
  • Loading branch information
pbrisbin committed Jan 3, 2023
1 parent 25127fc commit aee4a0e
Showing 1 changed file with 22 additions and 4 deletions.
26 changes: 22 additions & 4 deletions src/Database/Schema/Migrations/Filesystem.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, ScopedTypeVariables, OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, LambdaCase, ScopedTypeVariables, OverloadedStrings #-}
-- |This module provides a type for interacting with a
-- filesystem-backed 'MigrationStore'.
module Database.Schema.Migrations.Filesystem
Expand Down Expand Up @@ -28,6 +28,7 @@ import Control.Monad ( filterM )
import Control.Exception ( Exception(..), throw, catch )

import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import Data.HashMap.Strict as M (toList)
import qualified Data.Yaml as Yaml
import GHC.Generics (Generic)
Expand Down Expand Up @@ -113,8 +114,7 @@ data MigrationYaml = MigrationYaml
, myDescription :: Maybe Text
, myApply :: Text
, myRevert :: Maybe Text
, myDepends :: Maybe Text
-- ^ White-space separated names
, myDepends :: DependsYaml
}
deriving Generic

Expand All @@ -139,7 +139,7 @@ migrationYamlToMigration theId my = Migration
, mDesc = myDescription my
, mApply = myApply my
, mRevert = myRevert my
, mDeps = maybe [] T.words $ myDepends my
, mDeps = unDependsYaml $ myDepends my
}

newtype UTCTimeYaml = UTCTimeYaml
Expand All @@ -159,3 +159,21 @@ instance ToJSON UTCTimeYaml where
-- Keeps things as the old Show/Read-based format, e.g "2009-04-15 10:02:06 UTC"
utcTimeYamlFormat :: String
utcTimeYamlFormat = "%F %T UTC"

newtype DependsYaml = DependsYaml
{ unDependsYaml :: [Text]
}

instance FromJSON DependsYaml where
parseJSON = \case
Null -> pure $ DependsYaml []
String t -> pure $ DependsYaml $ T.words t
x -> typeMismatch "Null or whitespace-separated String" x

instance ToJSON DependsYaml where
toJSON (DependsYaml ts) = case ts of
[] -> toJSON Null
_ -> toJSON $ T.unwords ts
toEncoding (DependsYaml ts) = case ts of
[] -> toEncoding Null
_ -> toEncoding $ T.unwords ts

0 comments on commit aee4a0e

Please sign in to comment.