-- | Shared helpers for decoding the site's YAML documents into typed values
module MathiasSM.Yaml (
    decodeYaml,
    parseYamlList,
    Check (..),
    required,
    optional,
    enumFromJSON,
) where

import Data.Aeson (FromJSON (parseJSON), Object, Value (Null), withText)
import Data.Aeson.Key (fromString)
import Data.Aeson.KeyMap (lookup)
import Data.Aeson.Types (Parser, parseEither)
import Data.Bifunctor (first)
import Data.List (intercalate, stripPrefix)
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Yaml (decodeEither', prettyPrintParseException)
import MathiasSM.Metadata (Key, keyName)
import Prelude hiding (lookup)

-- | Decodes a YAML document, reporting the parse problems found
decodeYaml :: (FromJSON a) => String -> Either [String] a
decodeYaml :: forall a. FromJSON a => String -> Either [String] a
decodeYaml = (ParseException -> [String])
-> Either ParseException a -> Either [String] a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\ParseException
e -> [ParseException -> String
prettyPrintParseException ParseException
e]) (Either ParseException a -> Either [String] a)
-> (String -> Either ParseException a)
-> String
-> Either [String] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseException a
forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' (ByteString -> Either ParseException a)
-> (String -> ByteString) -> String -> Either ParseException a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- | Decodes a top-level YAML list of objects, parsing each one and prefixing its problems by index
parseYamlList :: String -> (Object -> Either [String] a) -> String -> Either [String] [a]
parseYamlList :: forall a.
String
-> (Object -> Either [String] a) -> String -> Either [String] [a]
parseYamlList String
what Object -> Either [String] a
parseOne String
text = do
    objects <- String -> Either [String] [Object]
forall a. FromJSON a => String -> Either [String] a
decodeYaml String
text
    let numbered = [Int] -> [Either [String] a] -> [(Int, Either [String] a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ((Object -> Either [String] a) -> [Object] -> [Either [String] a]
forall a b. (a -> b) -> [a] -> [b]
map Object -> Either [String] a
parseOne [Object]
objects)
        problems = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
prefix Int
index) [String]
ps | (Int
index, Left [String]
ps) <- [(Int, Either [String] a)]
numbered]
        parsed = [a
x | (Int
_, Right a
x) <- [(Int, Either [String] a)]
numbered]
    if null problems then Right parsed else Left problems
  where
    prefix :: Int -> String -> String
prefix Int
index String
problem = String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" #" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
index String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
problem

-- | Accepts exactly the spellings @render@ produces
enumFromJSON :: (Enum a, Bounded a) => String -> (a -> String) -> Value -> Parser a
enumFromJSON :: forall a.
(Enum a, Bounded a) =>
String -> (a -> String) -> Value -> Parser a
enumFromJSON String
what a -> String
render = String -> (Text -> Parser a) -> Value -> Parser a
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
what ((Text -> Parser a) -> Value -> Parser a)
-> (Text -> Parser a) -> Value -> Parser a
forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case [a
x | a
x <- [a
forall a. Bounded a => a
minBound .. a
forall a. Bounded a => a
maxBound], a -> String
render a
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> String
T.unpack Text
t] of
        a
x : [a]
_ -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
        [] ->
            String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$
                String
"unknown "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" \""
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" (expected "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
render [a
forall a. Bounded a => a
minBound .. a
forall a. Bounded a => a
maxBound])
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

-- | Like 'Either', but combining failures instead of stopping at the first
newtype Check a = Check {forall a. Check a -> Either [String] a
runCheck :: Either [String] a}

instance Functor Check where
    fmap :: forall a b. (a -> b) -> Check a -> Check b
fmap a -> b
f (Check Either [String] a
r) = Either [String] b -> Check b
forall a. Either [String] a -> Check a
Check ((a -> b) -> Either [String] a -> Either [String] b
forall a b. (a -> b) -> Either [String] a -> Either [String] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Either [String] a
r)

instance Applicative Check where
    pure :: forall a. a -> Check a
pure = Either [String] a -> Check a
forall a. Either [String] a -> Check a
Check (Either [String] a -> Check a)
-> (a -> Either [String] a) -> a -> Check a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either [String] a
forall a b. b -> Either a b
Right
    Check (Left [String]
a) <*> :: forall a b. Check (a -> b) -> Check a -> Check b
<*> Check (Left [String]
b) = Either [String] b -> Check b
forall a. Either [String] a -> Check a
Check ([String] -> Either [String] b
forall a b. a -> Either a b
Left ([String]
a [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
b))
    Check (Left [String]
a) <*> Check Either [String] a
_ = Either [String] b -> Check b
forall a. Either [String] a -> Check a
Check ([String] -> Either [String] b
forall a b. a -> Either a b
Left [String]
a)
    Check (Right a -> b
f) <*> Check Either [String] a
r = Either [String] b -> Check b
forall a. Either [String] a -> Check a
Check ((a -> b) -> Either [String] a -> Either [String] b
forall a b. (a -> b) -> Either [String] a -> Either [String] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Either [String] a
r)

required :: (FromJSON a) => Object -> Key -> Check a
required :: forall a. FromJSON a => Object -> Key -> Check a
required Object
o Key
key = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
lookup (String -> Key
fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Key -> String
keyName Key
key) Object
o of
    Maybe Value
Nothing -> Either [String] a -> Check a
forall a. Either [String] a -> Check a
Check (Either [String] a -> Check a) -> Either [String] a -> Check a
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] a
forall a b. a -> Either a b
Left [Key -> String
keyName Key
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": missing"]
    Just Value
Null -> Either [String] a -> Check a
forall a. Either [String] a -> Check a
Check (Either [String] a -> Check a) -> Either [String] a -> Check a
forall a b. (a -> b) -> a -> b
$ [String] -> Either [String] a
forall a b. a -> Either a b
Left [Key -> String
keyName Key
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": missing"]
    Just Value
v -> Either [String] a -> Check a
forall a. Either [String] a -> Check a
Check (Either [String] a -> Check a) -> Either [String] a -> Check a
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Either [String] a
forall a. FromJSON a => Key -> Value -> Either [String] a
decodeField Key
key Value
v

optional :: (FromJSON a) => Object -> Key -> Check (Maybe a)
optional :: forall a. FromJSON a => Object -> Key -> Check (Maybe a)
optional Object
o Key
key = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
lookup (String -> Key
fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Key -> String
keyName Key
key) Object
o of
    Maybe Value
Nothing -> Maybe a -> Check (Maybe a)
forall a. a -> Check a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Just Value
Null -> Maybe a -> Check (Maybe a)
forall a. a -> Check a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Just Value
v -> Either [String] (Maybe a) -> Check (Maybe a)
forall a. Either [String] a -> Check a
Check (Either [String] (Maybe a) -> Check (Maybe a))
-> Either [String] (Maybe a) -> Check (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either [String] a -> Either [String] (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Value -> Either [String] a
forall a. FromJSON a => Key -> Value -> Either [String] a
decodeField Key
key Value
v

decodeField :: (FromJSON a) => Key -> Value -> Either [String] a
decodeField :: forall a. FromJSON a => Key -> Value -> Either [String] a
decodeField Key
key = (String -> [String]) -> Either String a -> Either [String] a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\String
e -> [Key -> String
keyName Key
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
clean String
e]) (Either String a -> Either [String] a)
-> (Value -> Either String a) -> Value -> Either [String] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON
  where
    clean :: String -> String
clean String
e = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
e (String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"Error in $: " String
e)