{-# LANGUAGE AllowAmbiguousTypes #-}

-- | Instances of t'Yamlet.Decode.FromYaml' and t'Yamlet.Encode.ToYaml' from
-- the t'GHC.Generics.Generic' representation of a type.
--
-- A type derives the instances via t'GenericYaml', and its instance of
-- 'GenericYamlOptions' gives the options:
--
-- >>> :{
-- data Server = Server {host :: T.Text, port :: Int}
--   deriving stock (Generic, Show)
--   deriving anyclass (GenericYamlOptions)
--   deriving (FromYaml, ToYaml) via GenericYaml Server
-- :}
--
-- >>> decodeText @Server "host: localhost\nport: 80\n"
-- Right (Server {host = "localhost", port = 80})
--
-- >>> T.putStr (encodeText (Server "localhost" 80))
-- host: localhost
-- port: 80
--
-- A type with other options defines 'yamlOptions' in its instance of
-- 'GenericYamlOptions':
--
-- >>> :{
-- data Build = Build {sourcePaths :: [T.Text], ghcOptions :: [T.Text]}
--   deriving stock (Generic)
--   deriving (ToYaml) via GenericYaml Build
-- instance GenericYamlOptions Build where
--   yamlOptions = defaultYamlOptions {fieldLabelModifier = snakeCase}
-- :}
--
-- >>> T.putStr (encodeText (Build ["src"] ["-Wall"]))
-- source_paths:
-- - src
-- ghc_options:
-- - -Wall
--
-- = Encoding
--
-- The encoding of a type depends on its constructors and their fields:
--
-- * A record is a mapping of its fields, e.g. @{host: localhost, port: 80}@.
--
-- * A type whose constructors have no fields is a string with the name of
--   the constructor, e.g. @TurnLeft@. This includes a type with one such
--   constructor, which aeson writes as an empty list.
--
-- * A type with several constructors is a mapping with the name of the
--   constructor under the tag key, next to the fields of the constructor,
--   e.g. @{tag: Circle, radius: 1}@. A constructor with a field without a
--   name has its field under the contents key, e.g.
--   @{tag: Forward, contents: 10}@.
--
-- * A type with one constructor and a field without a name is its field.
--
-- * With the encoding 'TaggedFlat', the entries of a field without a name go
--   in the mapping of the constructor, e.g. @{tag: Ahead, distance: 10}@ for
--   @Ahead (Distance 10)@.
--
-- * With the encoding 'SingleField', a constructor is a mapping with its
--   name as the only key, e.g. @{Circle: {radius: 1}}@ or @{Forward: 10}@,
--   and a constructor without fields is its name, e.g. @Dot@. aeson writes
--   such a constructor as @{Dot: []}@.
--
-- The default encoding of a sum type is 'TaggedObject':
--
-- >>> :{
-- data Shape = Circle {radius :: Double} | Dot
--   deriving stock (Generic)
--   deriving anyclass (GenericYamlOptions)
--   deriving (ToYaml) via GenericYaml Shape
-- :}
--
-- >>> T.putStr (encodeText [Circle 1, Dot])
-- - tag: Circle
--   radius: 1.0
-- - tag: Dot
--
-- >>> :{
-- data Move = Forward Int | Stop
--   deriving stock (Generic)
--   deriving anyclass (GenericYamlOptions)
--   deriving (ToYaml) via GenericYaml Move
-- :}
--
-- >>> T.putStr (encodeText [Forward 10, Stop])
-- - tag: Forward
--   contents: 10
-- - tag: Stop
--
-- The instance of 'GenericYamlOptions' chooses another encoding:
--
-- >>> :{
-- data Distance = Distance {distance :: Int}
--   deriving stock (Generic)
--   deriving anyclass (GenericYamlOptions)
--   deriving (ToYaml) via GenericYaml Distance
-- :}
--
-- >>> :{
-- data Step = Ahead Distance | Halt
--   deriving stock (Generic)
--   deriving (ToYaml) via GenericYaml Step
-- instance GenericYamlOptions Step where
--   type SumEncoding Step = TaggedFlat
-- :}
--
-- >>> T.putStr (encodeText [Ahead (Distance 10), Halt])
-- - tag: Ahead
--   distance: 10
-- - tag: Halt
--
-- >>> :{
-- data Figure = Round {radius :: Double} | Named T.Text | Point
--   deriving stock (Generic)
--   deriving (ToYaml) via GenericYaml Figure
-- instance GenericYamlOptions Figure where
--   type SumEncoding Figure = SingleField
-- :}
--
-- >>> T.putStr (encodeText [Round 1, Named "x", Point])
-- - Round:
--     radius: 1.0
-- - Named: x
-- - Point
--
-- = Shapes
--
-- Every constructor must have no fields, one field without a name, or named
-- fields. A type with several constructors cannot mix named fields with a
-- field without a name, but a constructor without fields fits with both.
-- 'SingleField' allows the mix, because each constructor has its own value.
-- 'TaggedFlat' needs constructors with one field without a name or no
-- fields.
--
-- Another shape is a compile error that names the constructors, e.g. a
-- constructor with several fields without names. Give such fields names, or
-- with 'TaggedFlat', put them in a record type and make it the one field of
-- the constructor.
--
-- = Missing keys
--
-- A missing field takes its value from the 'yamlDefault' of the type that
-- has the field, if that type has a default. Otherwise the field decodes as
-- if its value is null. A missing contents key does the same. Thus a field
-- of type 'Maybe' is optional, and a missing field of another type is an
-- error, even if the type of the field has its own 'yamlDefault': only the
-- default of the type that has the field counts.
--
-- A type with a default configuration derives the decoder like this:
--
-- >>> :{
-- data Config = Config {name :: T.Text, retries :: Int, proxy :: Maybe T.Text}
--   deriving stock (Generic, Show)
--   deriving (FromYaml) via GenericYaml Config
-- instance GenericYamlOptions Config where
--   yamlDefault = Just (Config "app" 3 (Just "proxy.local"))
-- :}
--
-- >>> decodeText @Config "retries: 5\n"
-- Right (Config {name = "app", retries = 5, proxy = Just "proxy.local"})
--
-- >>> decodeText @Config "proxy: null\n"
-- Right (Config {name = "app", retries = 3, proxy = Nothing})
--
-- A field with the value 'requiredField' has no default:
--
-- >>> :{
-- data Account = Account {user :: T.Text, shell :: T.Text}
--   deriving stock (Generic, Show)
--   deriving (FromYaml) via GenericYaml Account
-- instance GenericYamlOptions Account where
--   yamlDefault = Just (Account requiredField "/bin/sh")
-- :}
--
-- >>> decodeText @Account "user: alice\n"
-- Right (Account {user = "alice", shell = "/bin/sh"})
--
-- >>> either printErrors print (decodeText @Account "shell: /bin/zsh\n")
-- input.yaml:1:1: missing key "user"
--   |
-- 1 | shell: /bin/zsh
--   | ^
--
-- A present key that holds a mapping takes the missing keys of that mapping
-- from the default of its own type, not from the outer default:
--
-- >>> :{
-- data Endpoint = Endpoint {host :: T.Text, port :: Int}
--   deriving stock (Generic, Show)
--   deriving (FromYaml) via GenericYaml Endpoint
-- instance GenericYamlOptions Endpoint where
--   yamlDefault = Just (Endpoint "localhost" 80)
-- :}
--
-- >>> :{
-- data Service = Service {name :: T.Text, endpoint :: Endpoint}
--   deriving stock (Generic, Show)
--   deriving (FromYaml) via GenericYaml Service
-- instance GenericYamlOptions Service where
--   yamlDefault = Just (Service "app" (Endpoint "example.com" 443))
-- :}
--
-- >>> decodeText @Service "endpoint:\n  port: 8080\n"
-- Right (Service {name = "app", endpoint = Endpoint {host = "localhost", port = 8080}})
--
-- >>> decodeText @Service "name: web\n"
-- Right (Service {name = "web", endpoint = Endpoint {host = "example.com", port = 443}})
--
-- With 'TaggedFlat', the keys of a field without a name are next to the tag,
-- but they belong to the field. The missing keys of the field also come
-- from the default of its type. The outer default applies to such a field
-- only if the constructor has no keys besides the tag.
--
-- An explicit null is not a missing key, so it goes to the decoder of the
-- field. E.g. @proxy: null@ gives 'Nothing' for a field of type 'Maybe', and
-- @proxy:@ without a value gives 'Nothing' too. An empty document is also
-- null, so a type with a default does not decode from it.
module Yamlet.Generic
  ( -- * Deriving
    GenericYaml (..)
  , GenericYamlOptions (..)
  , YamlOptions (..)
  , defaultYamlOptions
  , SumEncodingKind (..)
  , requiredField

    -- * Modifiers
  , snakeCase
  , kebabCase

    -- * Instances by hand
  , genericToYaml
  , genericParseYaml

    -- * Classes of the representation
  , GDatatype (Constructors)
  , GConstructors
  , GEncoding
  , GToConstructor
  , GFromConstructor
  , GFields
  , GToFields
  , GFromFields

    -- * Re-exports
  , Generic
  ) where

import Control.Exception hiding (TypeError)
import Control.Monad
import Data.Char
import Data.Coerce
import Data.Kind
import Data.Map.Strict qualified as M
import Data.Maybe
import Data.Proxy
import Data.Text qualified as T
import GHC.Generics
import GHC.TypeLits
import System.IO.Unsafe

import Yamlet.Internal.FromYaml
import Yamlet.Internal.Syntax qualified as S
import Yamlet.Internal.ToYaml
import Yamlet.Internal.Utils
import Yamlet.Internal.View
import Yamlet.Value

----------------------------------------
-- Deriving

-- | A newtype to derive t'Yamlet.Decode.FromYaml' and t'Yamlet.Encode.ToYaml'
-- with @deriving via@. The instances come from the t'GHC.Generics.Generic'
-- representation of the type and its instance of 'GenericYamlOptions'.
newtype GenericYaml a = GenericYaml a

instance
  ( Generic a
  , GenericYamlOptions a
  , GDatatype (Rep a)
  , Constructors (Rep a) ~ f
  , GConstructors f
  , GEncoding (SumEncoding a) f
  , GToConstructor f
  , ToYaml a
  )
  => ToYaml (GenericYaml a)
  where
  toYaml :: GenericYaml a -> Node
toYaml = (a -> Node) -> GenericYaml a -> Node
forall a b. Coercible a b => a -> b
coerce (forall a (f :: * -> *).
(Generic a, GenericYamlOptions a, GDatatype (Rep a),
 Constructors (Rep a) ~ f, GConstructors f,
 GEncoding (SumEncoding a) f, GToConstructor f) =>
a -> Node
genericToYaml @a)
  -- The pragma keeps the source of the method as its unfolding, and GHC
  -- inlines it at the type of the derived instance, together with
  -- 'genericToYaml'. Without it, GHC does not inline the optimized method
  -- there, the derived encoders keep the generic representation, and the
  -- inspection tests of the encoders fail.
  {-# INLINE toYaml #-}

  -- The list and the field encode their values with the instance of
  -- 'ToYaml a', for the reason at 'parseYamlList' below. With the defaults
  -- of the class, the benchmark derive.contents.toYaml.generic is slower.
  toYamlList :: [GenericYaml a] -> Node
toYamlList [GenericYaml a]
xs = [Node] -> Node
S.sequenceNode ((a -> Node) -> [a] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (forall a. ToYaml a => a -> Node
toYaml @a) ([GenericYaml a] -> [a]
forall a b. Coercible a b => a -> b
coerce [GenericYaml a]
xs))

  -- A type that is its field passes the key to the field.
  toYamlField :: Node -> GenericYaml a -> (Node, Node)
toYamlField Node
k (GenericYaml a
x)
    | Bool -> Bool
not (forall {k} (f :: k). GConstructors f => YamlOptions -> Bool
forall (f :: * -> *). GConstructors f => YamlOptions -> Bool
isTagged @f (forall a. GenericYamlOptions a => YamlOptions
yamlOptions @a))
    , Just (Node, Node)
entry <- Node -> Constructors (Rep a) (ZonkAny 3) -> Maybe (Node, Node)
forall p. Node -> Constructors (Rep a) p -> Maybe (Node, Node)
forall {k} (f :: k -> *) (p :: k).
GToConstructor f =>
Node -> f p -> Maybe (Node, Node)
gToUntaggedEntry Node
k (Rep a (ZonkAny 3) -> Constructors (Rep a) (ZonkAny 3)
forall p. Rep a p -> Constructors (Rep a) p
forall (r :: * -> *) p. GDatatype r => r p -> Constructors r p
gUnwrap (a -> Rep a (ZonkAny 3)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
x)) =
        (Node, Node)
entry
    | Bool
otherwise = (Node
k, forall a. ToYaml a => a -> Node
toYaml @a a
x)

instance
  ( Generic a
  , GenericYamlOptions a
  , GDatatype (Rep a)
  , Constructors (Rep a) ~ f
  , GConstructors f
  , GEncoding (SumEncoding a) f
  , GFromConstructor f
  , FromYaml a
  )
  => FromYaml (GenericYaml a)
  where
  parseYaml :: Node -> Parser (GenericYaml a)
parseYaml = (Node -> Parser a) -> Node -> Parser (GenericYaml a)
forall a b. Coercible a b => a -> b
coerce (forall a (f :: * -> *).
(Generic a, GenericYamlOptions a, GDatatype (Rep a),
 Constructors (Rep a) ~ f, GConstructors f,
 GEncoding (SumEncoding a) f, GFromConstructor f) =>
Node -> Parser a
genericParseYaml @a)
  -- The pragma has the reason of the one on 'toYaml'. Without it, the
  -- optimized method is too large for an unfolding, and the inspection tests
  -- of the decoders fail.
  {-# INLINE parseYaml #-}

  -- The list and the field decode their values with the instance of
  -- 'FromYaml a', i.e. the derived instance of the type, where GHC inlined
  -- the generic decoder at that type. The defaults of the class would call
  -- 'parseYaml' of this instance instead. GHC inlines the defaults here,
  -- where the type is not known, and the derived instance only calls the
  -- result. Each value would then go through the generic representation,
  -- and the benchmark derive.contents.parseYaml.generic would be slower.
  parseYamlList :: Node -> Parser [GenericYaml a]
parseYamlList = (Node -> Parser [a]) -> Node -> Parser [GenericYaml a]
forall a b. Coercible a b => a -> b
coerce (([Node] -> Parser [a]) -> Node -> Parser [a]
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence ((Node -> Parser a) -> [Node] -> Parser [a]
forall a. (Node -> Parser a) -> [Node] -> Parser [a]
parseItems (forall a. FromYaml a => Node -> Parser a
parseYaml @a)))
  -- The derived method applies this one to the dictionaries of the instance.
  -- The pragma inlines it there, so only the dictionary of 'FromYaml a'
  -- remains. Without the pragma, GHC 9.14 keeps the call with all the
  -- dictionaries, because its worker/wrapper does not drop unused
  -- dictionaries, and the inspection tests of the list decoders fail.
  {-# INLINE parseYamlList #-}

  -- A type that is its field passes the key to the field.
  parseYamlField :: Node -> Node -> Parser (GenericYaml a)
parseYamlField Node
k Node
v
    | Bool -> Bool
not (forall {k} (f :: k). GConstructors f => YamlOptions -> Bool
forall (f :: * -> *). GConstructors f => YamlOptions -> Bool
isTagged @f (forall a. GenericYamlOptions a => YamlOptions
yamlOptions @a))
    , Just Parser a
p <- (f (ZonkAny 2) -> a) -> (Node, Node) -> Maybe (Parser a)
forall p a. (f p -> a) -> (Node, Node) -> Maybe (Parser a)
forall {k} (f :: k -> *) (p :: k) a.
GFromConstructor f =>
(f p -> a) -> (Node, Node) -> Maybe (Parser a)
gFromUntaggedEntry (Rep a (ZonkAny 2) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a (ZonkAny 2) -> a)
-> (f (ZonkAny 2) -> Rep a (ZonkAny 2)) -> f (ZonkAny 2) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (ZonkAny 2) -> Rep a (ZonkAny 2)
Constructors (Rep a) (ZonkAny 2) -> Rep a (ZonkAny 2)
forall p. Constructors (Rep a) p -> Rep a p
forall (r :: * -> *) p. GDatatype r => Constructors r p -> r p
gWrap) (Node
k, Node
v) =
        forall a b. Coercible a b => a -> b
forall a b. Coercible a b => a -> b
coerce @(Parser a) Parser a
p
    | Bool
otherwise = Parser a -> Parser (GenericYaml a)
forall a b. Coercible a b => a -> b
coerce (forall a. FromYaml a => Node -> Parser a
parseYaml @a Node
v)

----------------------------------------
-- Options

-- | How a type is encoded and decoded.
--
-- The instances do not check the options. Options that give two keys of a
-- mapping or two constructors the same text encode values that do not read
-- back, as the fields below describe.
data YamlOptions = YamlOptions
  { YamlOptions -> String -> String
fieldLabelModifier :: !(String -> String)
  -- ^ The key of a field from the name of the field. If two fields of a
  -- constructor get the same key, e.g. @fooBar@ and @foo_bar@ with
  -- 'snakeCase', the constructor encodes as a mapping with two equal keys,
  -- which does not read back.
  , YamlOptions -> String -> String
constructorTagModifier :: !(String -> String)
  -- ^ The tag of a constructor from the name of the constructor. If two
  -- constructors get the same tag, e.g. @FooBar@ and @Foo_bar@ with
  -- 'snakeCase', the decoder reads the tag as the first of them.
  , YamlOptions -> Text
tagKey :: !T.Text
  -- ^ The key of the tag, @tag@ by default. A record with a field of the same
  -- key encodes as a mapping with two equal keys, which does not read back.
  , YamlOptions -> Text
contentsKey :: !T.Text
  -- ^ The key of the fields of a tagged constructor without field names,
  -- @contents@ by default. If it is the same as 'Yamlet.Generic.tagKey', such
  -- a constructor encodes as a mapping with two equal keys, which does not
  -- read back.
  , YamlOptions -> Bool
tagSingleConstructors :: !Bool
  -- ^ Give a type with one constructor a tag too, unless the constructor has
  -- no fields. Off by default.
  , YamlOptions -> Bool
omitNullFields :: !Bool
  -- ^ Leave out a field whose value is null, e.g. 'Nothing'. Off by default.
  -- A null field with comments stays, e.g. a t'Yamlet.Commented' field with
  -- the value 'Nothing' and a comment. So does a null field with an anchor,
  -- which an alias elsewhere can refer to.
  --
  -- With 'yamlDefault', a null field stays unless its default is null without
  -- comments. Otherwise the value would not read back: the decoder fills a
  -- missing key from the default, so e.g. a field 'Nothing' with the default
  -- @Just 1@ would read back as @Just 1@. A value that encodes as its default
  -- still reads back as the default, e.g. a field 'Nothing' of type
  -- @Maybe (Maybe a)@ with the default @Just Nothing@, because both encode as
  -- null.
  , YamlOptions -> Bool
rejectUnknownFields :: !Bool
  -- ^ Reject a key that is not a field of the constructor. On by default.
  --
  -- Turn it off for a document with keys that the type does not model, e.g.
  -- keys that only hold anchors. The decoder then ignores such keys, and an
  -- encode of the value leaves them out.
  }
  deriving stock ((forall x. YamlOptions -> Rep YamlOptions x)
-> (forall x. Rep YamlOptions x -> YamlOptions)
-> Generic YamlOptions
forall x. Rep YamlOptions x -> YamlOptions
forall x. YamlOptions -> Rep YamlOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. YamlOptions -> Rep YamlOptions x
from :: forall x. YamlOptions -> Rep YamlOptions x
$cto :: forall x. Rep YamlOptions x -> YamlOptions
to :: forall x. Rep YamlOptions x -> YamlOptions
Generic)

-- | The options with the defaults that the fields of t'YamlOptions' name.
defaultYamlOptions :: YamlOptions
defaultYamlOptions :: YamlOptions
defaultYamlOptions =
  YamlOptions
    { fieldLabelModifier :: String -> String
fieldLabelModifier = String -> String
forall a. a -> a
id
    , constructorTagModifier :: String -> String
constructorTagModifier = String -> String
forall a. a -> a
id
    , tagKey :: Text
tagKey = Text
"tag"
    , contentsKey :: Text
contentsKey = Text
"contents"
    , tagSingleConstructors :: Bool
tagSingleConstructors = Bool
False
    , omitNullFields :: Bool
omitNullFields = Bool
False
    , rejectUnknownFields :: Bool
rejectUnknownFields = Bool
True
    }

-- | How a tagged constructor goes in a mapping. The choice is a type, see
-- 'SumEncoding', because it changes the shapes of the constructors that a
-- type can have.
data SumEncodingKind
  = -- | The fields go next to the tag, e.g. @{tag: Circle, radius: 1}@, and a
    -- field without a name goes under the contents key, e.g.
    -- @{tag: Forward, contents: 10}@.
    --
    -- An enumeration is a string, but a constructor without fields in a type
    -- with fields is a mapping, e.g. @{tag: Stop}@. To keep the encoding of an
    -- enumeration when you add a constructor with fields, use 'SingleField'.
    TaggedObject
  | -- | The entries of a field without a name go next to the tag, e.g.
    -- @{tag: Ahead, distance: 10}@ for @Ahead (Distance 10)@. The
    -- constructors must have one field without a name or no fields,
    -- otherwise the derived instances are a type error.
    --
    -- The field must encode as a mapping with a key and without an anchor or
    -- a tag, and no key can be the tag key or the contents key. Otherwise
    -- the constructor encodes as with 'TaggedObject'. Thus the field of a
    -- type with the same tag key stays under the contents key, and so do a
    -- mapping with an anchor that an alias can refer to and a
    -- v'Yamlet.Value.Tagged' value.
    --
    -- Only the entries of the mapping go next to the tag. The comments of the
    -- mapping are lost, e.g. the comments of a t'Yamlet.Commented' value.
    -- 'TaggedObject' keeps them.
    --
    -- The decoder reads a mapping with the contents key as with
    -- 'TaggedObject', and the other keys are unknown keys. Without the
    -- contents key, the other keys are the field, so a field that is not a
    -- mapping needs the contents key. An error at the mapping itself, e.g.
    -- that a mapping is not an integer, has a note at the tag that says so.
    --
    -- The keys of the mapping belong to the field, so the options of its
    -- type apply to them, e.g. 'Yamlet.Generic.rejectUnknownFields'.
    TaggedFlat
  | -- | A mapping with one key, the tag, and the fields as its value, e.g.
    -- @{Circle: {radius: 1}}@. A field without a name is the value, e.g.
    -- @{Forward: 10}@, and a constructor without fields is its tag, e.g.
    -- @Dot@. The tag key and the contents key play no part.
    --
    -- Each constructor has its own value, so the constructors of a type can
    -- mix named fields with a field without a name. A second key in the
    -- mapping is an error. 'Yamlet.Generic.rejectUnknownFields' applies to
    -- the named fields in the value.
    --
    -- The key of a constructor with named fields is not a field, so its
    -- comments are lost. The key of a field without a name goes to the
    -- field, e.g. for a 'Yamlet.Commented' value.
    SingleField
  deriving stock (SumEncodingKind -> SumEncodingKind -> Bool
(SumEncodingKind -> SumEncodingKind -> Bool)
-> (SumEncodingKind -> SumEncodingKind -> Bool)
-> Eq SumEncodingKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SumEncodingKind -> SumEncodingKind -> Bool
== :: SumEncodingKind -> SumEncodingKind -> Bool
$c/= :: SumEncodingKind -> SumEncodingKind -> Bool
/= :: SumEncodingKind -> SumEncodingKind -> Bool
Eq, Int -> SumEncodingKind -> String -> String
[SumEncodingKind] -> String -> String
SumEncodingKind -> String
(Int -> SumEncodingKind -> String -> String)
-> (SumEncodingKind -> String)
-> ([SumEncodingKind] -> String -> String)
-> Show SumEncodingKind
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SumEncodingKind -> String -> String
showsPrec :: Int -> SumEncodingKind -> String -> String
$cshow :: SumEncodingKind -> String
show :: SumEncodingKind -> String
$cshowList :: [SumEncodingKind] -> String -> String
showList :: [SumEncodingKind] -> String -> String
Show)

-- | The configuration of the generic instances of t'Yamlet.Decode.FromYaml'
-- and t'Yamlet.Encode.ToYaml' for a type: the options and the default value.
class GenericYamlOptions a where
  -- | How a tagged constructor goes in a mapping, 'TaggedObject' by default.
  type SumEncoding a :: SumEncodingKind

  type SumEncoding a = TaggedObject

  -- | The options of the type, 'defaultYamlOptions' by default.
  yamlOptions :: YamlOptions
  yamlOptions = YamlOptions
defaultYamlOptions

  -- | The value that gives the fields of missing keys, e.g. the default
  -- configuration. Without it, a missing key decodes like null. A key with
  -- the value null is not missing. For a sum type, the default applies only
  -- to the constructor of the default value.
  yamlDefault :: Maybe a
  yamlDefault = Maybe a
forall a. Maybe a
Nothing

-- | The value of a field without a default in 'yamlDefault'. A missing key
-- of the field is an error, also if the field accepts null, e.g. for a field
-- of type 'Maybe'. The encoder with 'Yamlet.Generic.omitNullFields' keeps
-- such a field.
--
-- The value throws an exception when it is evaluated, also in your own code
-- that uses 'yamlDefault'. The generic instances evaluate each field of the
-- default to find the required fields, so:
--
-- * The field must be 'requiredField' itself, e.g. @Just requiredField@ is not
--   a valid default value for the field of type @Maybe Text@.
--
-- * The field must be lazy and not a field of a newtype.
--
-- With 'TaggedFlat', the keys next to the tag can belong to a field without
-- a name, e.g. @distance@ in @{tag: Ahead, distance: 10}@ for
-- @Ahead (Distance 10)@. To require such a key, use 'requiredField' in the
-- default of the type of the field, e.g. @Distance@, not of the sum type.
requiredField :: a
requiredField :: forall a. a
requiredField = RequiredField -> a
forall a e. (HasCallStack, Exception e) => e -> a
throw RequiredField
RequiredField

-- | The exception of 'requiredField'.
data RequiredField = RequiredField
  deriving stock (Int -> RequiredField -> String -> String
[RequiredField] -> String -> String
RequiredField -> String
(Int -> RequiredField -> String -> String)
-> (RequiredField -> String)
-> ([RequiredField] -> String -> String)
-> Show RequiredField
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> RequiredField -> String -> String
showsPrec :: Int -> RequiredField -> String -> String
$cshow :: RequiredField -> String
show :: RequiredField -> String
$cshowList :: [RequiredField] -> String -> String
showList :: [RequiredField] -> String -> String
Show)

instance Exception RequiredField where
  displayException :: RequiredField -> String
displayException RequiredField
_ = String
"the field has no default"

-- | The field of a default, or 'Nothing' for 'requiredField'.
defaultField :: a -> Maybe a
-- Masking asynchronous exceptions inside 'unsafeDupablePerformIO' is a
-- workaround for https://gitlab.haskell.org/ghc/ghc/-/work_items/24189.
defaultField :: forall a. a -> Maybe a
defaultField a
x = case IO (Either RequiredField a) -> Either RequiredField a
forall a. IO a -> a
unsafeDupablePerformIO (IO (Either RequiredField a) -> IO (Either RequiredField a)
forall a. IO a -> IO a
uninterruptibleMask_ (IO a -> IO (Either RequiredField a)
forall e a. Exception e => IO a -> IO (Either e a)
try (a -> IO a
forall a. a -> IO a
evaluate a
x))) of
  Left RequiredField
RequiredField -> Maybe a
forall a. Maybe a
Nothing
  Right a
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x

-- | An error if the 'yamlDefault' of the type has a 'requiredField' in a
-- strict field or in the field of a newtype. Without the check, each field
-- would look required, and a missing key would give the error of a field
-- that has a default.
checkDefault :: forall a. (GenericYamlOptions a, GDatatype (Rep a)) => ()
checkDefault :: forall a. (GenericYamlOptions a, GDatatype (Rep a)) => ()
checkDefault = case forall a. GenericYamlOptions a => Maybe a
yamlDefault @a of
  Just a
d
    | Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing (a -> Maybe a
forall a. a -> Maybe a
defaultField a
d) ->
        String -> ()
forall a. HasCallStack => String -> a
error (String -> ()) -> String -> ()
forall a b. (a -> b) -> a -> b
$
          String
"requiredField in a strict field or a newtype of the default of "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ forall (r :: * -> *). GDatatype r => String
gDatatypeName @(Rep a)
  Maybe a
_ -> ()
-- Without the pragma, the derived encoders and decoders of lists and fields
-- keep the generic dictionaries, and their inspection tests fail.
{-# INLINE checkDefault #-}

-- | The words of a name in lower case, separated by underscores, e.g.
-- @source_paths@ for @sourcePaths@ or @SourcePaths@, and @http_server@ for
-- @HTTPServer@. The rules are the same as for @camelTo2 \'_\'@ of aeson.
--
-- >>> map snakeCase ["sourcePaths", "SourcePaths", "HTTPServer", "ghcVersion2"]
-- ["source_paths","source_paths","http_server","ghc_version2"]
snakeCase :: String -> String
snakeCase :: String -> String
snakeCase = Char -> String -> String
separateWords Char
'_'

-- | Like 'snakeCase', but with hyphens, e.g. @source-paths@ for
-- @sourcePaths@.
--
-- >>> kebabCase "sourcePaths"
-- "source-paths"
kebabCase :: String -> String
kebabCase :: String -> String
kebabCase = Char -> String -> String
separateWords Char
'-'

-- A word starts at an upper-case letter after a lower-case one, and at the
-- last letter of an acronym before a lower-case one.
separateWords :: Char -> String -> String
separateWords :: Char -> String -> String
separateWords Char
sep = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
afterLower (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
beforeLower
  where
    beforeLower :: String -> String
    beforeLower :: String -> String
beforeLower = \case
      Char
x : Char
u : Char
l : String
rest | Char -> Bool
isUpper Char
u Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
l -> Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Char
sep Char -> String -> String
forall a. a -> [a] -> [a]
: Char
u Char -> String -> String
forall a. a -> [a] -> [a]
: Char
l Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
beforeLower String
rest
      Char
x : String
rest -> Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
beforeLower String
rest
      [] -> []

    afterLower :: String -> String
    afterLower :: String -> String
afterLower = \case
      Char
l : Char
u : String
rest | Char -> Bool
isLower Char
l Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
u -> Char
l Char -> String -> String
forall a. a -> [a] -> [a]
: Char
sep Char -> String -> String
forall a. a -> [a] -> [a]
: Char
u Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
afterLower String
rest
      Char
x : String
rest -> Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
afterLower String
rest
      [] -> []

----------------------------------------
-- Constructors

-- An equality such as @Rep a ~ D1 d f@ would do the same as this class, but
-- for a type without a 'Generic' instance, GHC would report that the equality
-- fails instead of the missing instance.

-- | The layer of the data type at the top of a representation, and the
-- constructors below it. This class and the others of the representation
-- appear in the constraints of 'genericToYaml' and 'genericParseYaml'. Their
-- methods are internal.
class GDatatype (r :: Type -> Type) where
  type Constructors r :: Type -> Type

  gUnwrap :: r p -> Constructors r p

  gWrap :: Constructors r p -> r p

  gDatatypeName :: String

instance KnownSymbol name => GDatatype (D1 (MetaData name m p nt) f) where
  type Constructors (D1 (MetaData name m p nt) f) = f

  gUnwrap :: forall p.
D1 ('MetaData name m p nt) f p
-> Constructors (D1 ('MetaData name m p nt) f) p
gUnwrap = M1 D ('MetaData name m p nt) f p -> f p
M1 D ('MetaData name m p nt) f p
-> Constructors (D1 ('MetaData name m p nt) f) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

  gWrap :: forall p.
Constructors (D1 ('MetaData name m p nt) f) p
-> D1 ('MetaData name m p nt) f p
gWrap = f p -> M1 D ('MetaData name m p nt) f p
Constructors (D1 ('MetaData name m p nt) f) p
-> M1 D ('MetaData name m p nt) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1

  gDatatypeName :: String
gDatatypeName = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)

-- | The names and the number of the constructors of a representation.
class GConstructors f where
  gConstructorNames :: [String]

  gConstructorCount :: Int

  -- | No constructor has fields.
  gNullary :: Bool

instance (GConstructors f, GConstructors g) => GConstructors (f :+: g) where
  gConstructorNames :: [String]
gConstructorNames = forall {k} (f :: k). GConstructors f => [String]
forall (f :: k -> *). GConstructors f => [String]
gConstructorNames @f [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ forall {k} (f :: k). GConstructors f => [String]
forall (f :: k -> *). GConstructors f => [String]
gConstructorNames @g

  gConstructorCount :: Int
gConstructorCount = forall {k} (f :: k). GConstructors f => Int
forall (f :: k -> *). GConstructors f => Int
gConstructorCount @f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall {k} (f :: k). GConstructors f => Int
forall (f :: k -> *). GConstructors f => Int
gConstructorCount @g

  gNullary :: Bool
gNullary = forall {k} (f :: k). GConstructors f => Bool
forall (f :: k -> *). GConstructors f => Bool
gNullary @f Bool -> Bool -> Bool
&& forall {k} (f :: k). GConstructors f => Bool
forall (f :: k -> *). GConstructors f => Bool
gNullary @g

instance GConstructors V1 where
  gConstructorNames :: [String]
gConstructorNames = []

  gConstructorCount :: Int
gConstructorCount = Int
0

  gNullary :: Bool
gNullary = Bool
True

-- | The error for a type without constructors, whose representation is 'V1'.
type NoConstructors = Text "A type without constructors cannot derive FromYaml or ToYaml"

instance
  (KnownSymbol name, GFields f)
  => GConstructors (C1 (MetaCons name fixity isRecord) f)
  where
  gConstructorNames :: [String]
gConstructorNames = [Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)]

  gConstructorCount :: Int
gConstructorCount = Int
1

  gNullary :: Bool
gNullary = forall {k} (f :: k). GFields f => Int
forall (f :: k -> *). GFields f => Int
gArity @f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0

-- The instances check the shape of the constructors, because every derived
-- instance needs this class.

-- | The value of 'SumEncoding', if the constructors allow it.
class GEncoding (e :: SumEncodingKind) f where
  gEncoding :: SumEncodingKind

instance ValidShape (GShape TaggedObject f) => GEncoding TaggedObject f where
  gEncoding :: SumEncodingKind
gEncoding = forall (s :: Shape). ValidShape s => ()
validShape @(GShape TaggedObject f) () -> SumEncodingKind -> SumEncodingKind
forall a b. a -> b -> b
`seq` SumEncodingKind
TaggedObject

instance ValidShape (GShape TaggedFlat f) => GEncoding TaggedFlat f where
  gEncoding :: SumEncodingKind
gEncoding = forall (s :: Shape). ValidShape s => ()
validShape @(GShape TaggedFlat f) () -> SumEncodingKind -> SumEncodingKind
forall a b. a -> b -> b
`seq` SumEncodingKind
TaggedFlat

instance ValidShape (SingleShape f) => GEncoding SingleField f where
  gEncoding :: SumEncodingKind
gEncoding = forall (s :: Shape). ValidShape s => ()
validShape @(SingleShape f) () -> SumEncodingKind -> SumEncodingKind
forall a b. a -> b -> b
`seq` SumEncodingKind
SingleField

-- | The fields of the constructors of a type. A constructor without fields
-- fits with both kinds of fields.
data Shape
  = NoFields
  | -- | One field without a name, in the constructor with the name.
    UnnamedField Symbol
  | -- | Named fields, in the constructor with the name.
    NamedFields Symbol

-- | The shape of the constructors with the sum encoding. A constructor with
-- several fields without names, named fields with 'TaggedFlat', and a type
-- that mixes named fields with a field without a name, are type errors.
type family GShape (e :: SumEncodingKind) (f :: Type -> Type) :: Shape where
  GShape e (f :+: g) = CombineShapes (GShape e f) (GShape e g)
  GShape TaggedFlat (C1 (MetaCons name fixity True) f) =
    TypeError
      ( Text "TaggedFlat needs constructors with one field without a name, but the constructor "
          :<>: Text name
          :<>: Text " has named fields."
          :$$: FlatFieldsFix
      )
  GShape e (C1 (MetaCons name fixity True) f) = NamedFields name
  GShape e (C1 (MetaCons name fixity False) U1) = NoFields
  GShape e (C1 (MetaCons name fixity False) (S1 m f)) = UnnamedField name
  GShape e (C1 (MetaCons name fixity False) (f :*: g)) =
    TypeError
      ( Text "The constructor "
          :<>: Text name
          :<>: Text " has several fields without names."
          :$$: SeveralFieldsFix e
      )
  GShape e V1 = TypeError NoConstructors

type family SeveralFieldsFix (e :: SumEncodingKind) :: ErrorMessage where
  SeveralFieldsFix TaggedFlat = FlatFieldsFix
  SeveralFieldsFix e = Text "Give the fields names."

type FlatFieldsFix =
  Text "Put the fields in a record type, and make it the one field of the constructor."

type family CombineShapes (a :: Shape) (b :: Shape) :: Shape where
  CombineShapes NoFields b = b
  CombineShapes a NoFields = a
  CombineShapes (NamedFields a) (NamedFields _) = NamedFields a
  CombineShapes (UnnamedField a) (UnnamedField _) = UnnamedField a
  CombineShapes (NamedFields a) (UnnamedField b) = MixedFields a b
  CombineShapes (UnnamedField b) (NamedFields a) = MixedFields a b

type family MixedFields (named :: Symbol) (unnamed :: Symbol) :: Shape where
  MixedFields named unnamed =
    TypeError
      ( Text "The constructor "
          :<>: Text named
          :<>: Text " has named fields and the constructor "
          :<>: Text unnamed
          :<>: Text " has one field without a name."
          :$$: Text
                 "Give them the same kind of fields, or use the sum encoding SingleField, where each constructor has its own value."
      )

-- | The shape is valid. The instances match on the shape, so that GHC
-- reduces it and reports its type errors. With deferred type errors, e.g. in
-- a test of the errors, the method throws the error at run time.
class ValidShape (s :: Shape) where
  validShape :: ()

instance ValidShape NoFields where validShape :: ()
validShape = ()
instance ValidShape (UnnamedField name) where validShape :: ()
validShape = ()
instance ValidShape (NamedFields name) where validShape :: ()
validShape = ()

-- | A shape of 'SingleField', which checks each constructor as 'GShape' does,
-- but lets the constructors mix their fields. The equations match both
-- shapes, so that GHC reduces both and reports their type errors.
type family SingleShape (f :: Type -> Type) :: Shape where
  SingleShape (f :+: g) = EitherShape (SingleShape f) (SingleShape g)
  SingleShape f = GShape SingleField f

type family EitherShape (a :: Shape) (b :: Shape) :: Shape where
  EitherShape NoFields b = b
  EitherShape a NoFields = a
  EitherShape (NamedFields a) (NamedFields _) = NamedFields a
  EitherShape (NamedFields a) (UnnamedField _) = NamedFields a
  EitherShape (UnnamedField a) (NamedFields _) = UnnamedField a
  EitherShape (UnnamedField a) (UnnamedField _) = UnnamedField a

isTagged :: forall f. GConstructors f => YamlOptions -> Bool
isTagged :: forall {k} (f :: k). GConstructors f => YamlOptions -> Bool
isTagged YamlOptions
opts = YamlOptions
opts.tagSingleConstructors Bool -> Bool -> Bool
|| forall (f :: k). GConstructors f => Int
forall {k} (f :: k). GConstructors f => Int
gConstructorCount @f Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1

constructorTag :: YamlOptions -> String -> T.Text
constructorTag :: YamlOptions -> String -> Text
constructorTag YamlOptions
opts = String -> Text
T.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YamlOptions
opts.constructorTagModifier

-- | The tag of the constructor with the name.
constructorTagOf :: forall name. KnownSymbol name => YamlOptions -> T.Text
constructorTagOf :: forall (name :: Symbol). KnownSymbol name => YamlOptions -> Text
constructorTagOf YamlOptions
opts = YamlOptions -> String -> Text
constructorTag YamlOptions
opts (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name))

-- | The default of the first constructor of a sum, if it is the default.
leftDefault :: Maybe ((f :+: g) p) -> Maybe (f p)
leftDefault :: forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:+:) f g p) -> Maybe (f p)
leftDefault Maybe ((:+:) f g p)
def =
  Maybe ((:+:) f g p)
def Maybe ((:+:) f g p) -> ((:+:) f g p -> Maybe (f p)) -> Maybe (f p)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    L1 f p
x -> f p -> Maybe (f p)
forall a. a -> Maybe a
Just f p
x
    R1 g p
_ -> Maybe (f p)
forall a. Maybe a
Nothing

-- | The default of the second constructor of a sum, if it is the default.
rightDefault :: Maybe ((f :+: g) p) -> Maybe (g p)
rightDefault :: forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:+:) f g p) -> Maybe (g p)
rightDefault Maybe ((:+:) f g p)
def =
  Maybe ((:+:) f g p)
def Maybe ((:+:) f g p) -> ((:+:) f g p -> Maybe (g p)) -> Maybe (g p)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    R1 g p
x -> g p -> Maybe (g p)
forall a. a -> Maybe a
Just g p
x
    L1 f p
_ -> Maybe (g p)
forall a. Maybe a
Nothing

-- | The first fields of the default of a product.
firstDefault :: Maybe ((f :*: g) p) -> Maybe (f p)
firstDefault :: forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:*:) f g p) -> Maybe (f p)
firstDefault = ((:*:) f g p -> f p) -> Maybe ((:*:) f g p) -> Maybe (f p)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(f p
a :*: g p
_) -> f p
a)

-- | The second fields of the default of a product.
secondDefault :: Maybe ((f :*: g) p) -> Maybe (g p)
secondDefault :: forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:*:) f g p) -> Maybe (g p)
secondDefault = ((:*:) f g p -> g p) -> Maybe ((:*:) f g p) -> Maybe (g p)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(f p
_ :*: g p
b) -> g p
b)

----------------------------------------
-- Fields

-- | The names and the number of the fields of a constructor.
class GFields f where
  -- | The fields have names.
  gNamed :: Bool

  gArity :: Int

  -- | The keys of the fields.
  gNames :: YamlOptions -> [T.Text]

instance GFields U1 where
  gNamed :: Bool
gNamed = Bool
False

  gArity :: Int
gArity = Int
0

  gNames :: YamlOptions -> [Text]
gNames YamlOptions
_ = []

instance (GFields f, GFields g) => GFields (f :*: g) where
  gNamed :: Bool
gNamed = forall {k} (f :: k). GFields f => Bool
forall (f :: k -> *). GFields f => Bool
gNamed @f

  gArity :: Int
gArity = forall {k} (f :: k). GFields f => Int
forall (f :: k -> *). GFields f => Int
gArity @f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall {k} (f :: k). GFields f => Int
forall (f :: k -> *). GFields f => Int
gArity @g

  gNames :: YamlOptions -> [Text]
gNames YamlOptions
opts = forall {k} (f :: k). GFields f => YamlOptions -> [Text]
forall (f :: k -> *). GFields f => YamlOptions -> [Text]
gNames @f YamlOptions
opts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ forall {k} (f :: k). GFields f => YamlOptions -> [Text]
forall (f :: k -> *). GFields f => YamlOptions -> [Text]
gNames @g YamlOptions
opts

instance KnownSymbol name => GFields (S1 (MetaSel (Just name) u s d) f) where
  gNamed :: Bool
gNamed = Bool
True

  gArity :: Int
gArity = Int
1

  gNames :: YamlOptions -> [Text]
gNames YamlOptions
opts = [forall (name :: Symbol). KnownSymbol name => YamlOptions -> Text
fieldKey @name YamlOptions
opts]

instance GFields (S1 (MetaSel Nothing u s d) f) where
  gNamed :: Bool
gNamed = Bool
False

  gArity :: Int
gArity = Int
1

  gNames :: YamlOptions -> [Text]
gNames YamlOptions
_ = []

fieldKey :: forall name. KnownSymbol name => YamlOptions -> T.Text
fieldKey :: forall (name :: Symbol). KnownSymbol name => YamlOptions -> Text
fieldKey YamlOptions
opts = String -> Text
T.pack (YamlOptions
opts.fieldLabelModifier (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)))

----------------------------------------
-- Encoding

-- | The generic encoder, e.g. for an instance by hand that encodes some
-- values in another way.
--
-- >>> :{
-- data Size = Size {width :: Int, height :: Int}
--   deriving stock (Generic)
--   deriving anyclass (GenericYamlOptions)
-- instance ToYaml Size where
--   toYaml s
--     | s.width == 0 && s.height == 0 = toYaml ("empty" :: T.Text)
--     | otherwise = genericToYaml s
-- :}
--
-- >>> T.putStr (encodeText [Size 0 0, Size 1 2])
-- - empty
-- - width: 1
--   height: 2

-- GHC must inline the generic code in the derived method before the
-- specializer runs. Otherwise the specializer makes a copy of the code for
-- each node of the representation, and a large type takes several times
-- longer to compile. For the same reason, the top of the representation goes
-- to a plain function, not to a class with one method. GHC represents the
-- dictionary of such a class as a partial application of the method, and it
-- does not inline that.
genericToYaml
  :: forall a f
   . ( Generic a
     , GenericYamlOptions a
     , GDatatype (Rep a)
     , Constructors (Rep a) ~ f
     , GConstructors f
     , GEncoding (SumEncoding a) f
     , GToConstructor f
     )
  => a -> S.Node
genericToYaml :: forall a (f :: * -> *).
(Generic a, GenericYamlOptions a, GDatatype (Rep a),
 Constructors (Rep a) ~ f, GConstructors f,
 GEncoding (SumEncoding a) f, GToConstructor f) =>
a -> Node
genericToYaml a
x =
  -- Forcing the encoding forces the check of the shape, e.g. with deferred
  -- type errors in a test of the errors.
  let enc :: SumEncodingKind
enc = forall {k} (e :: SumEncodingKind) (f :: k).
GEncoding e f =>
SumEncodingKind
forall (e :: SumEncodingKind) (f :: * -> *).
GEncoding e f =>
SumEncodingKind
gEncoding @(SumEncoding a) @f
      -- The keys of the options are texts that GHC does not know to be
      -- evaluated. Without the bang, it evaluates them in each branch of the
      -- constructors, and it keeps the generic representation of a sum, as
      -- the inspection test of encodeShape shows. GHC before 9.12 keeps it
      -- also with the bang.
      !opts :: YamlOptions
opts = forall a. GenericYamlOptions a => YamlOptions
yamlOptions @a
  in SumEncodingKind
enc
       SumEncodingKind -> Node -> Node
forall a b. a -> b -> b
`seq` forall a. (GenericYamlOptions a, GDatatype (Rep a)) => ()
checkDefault @a
       () -> Node -> Node
forall a b. a -> b -> b
`seq` YamlOptions
-> SumEncodingKind
-> Maybe (Constructors (Rep a) (ZonkAny 0))
-> Constructors (Rep a) (ZonkAny 0)
-> Node
forall {k} (f :: k -> *) (p :: k).
(GConstructors f, GToConstructor f) =>
YamlOptions -> SumEncodingKind -> Maybe (f p) -> f p -> Node
gToYaml YamlOptions
opts SumEncodingKind
enc (Rep a (ZonkAny 0) -> Constructors (Rep a) (ZonkAny 0)
forall p. Rep a p -> Constructors (Rep a) p
forall (r :: * -> *) p. GDatatype r => r p -> Constructors r p
gUnwrap (Rep a (ZonkAny 0) -> Constructors (Rep a) (ZonkAny 0))
-> (a -> Rep a (ZonkAny 0))
-> a
-> Constructors (Rep a) (ZonkAny 0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a (ZonkAny 0)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from (a -> Constructors (Rep a) (ZonkAny 0))
-> Maybe a -> Maybe (Constructors (Rep a) (ZonkAny 0))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenericYamlOptions a => Maybe a
yamlDefault @a) (Rep a (ZonkAny 0) -> Constructors (Rep a) (ZonkAny 0)
forall p. Rep a p -> Constructors (Rep a) p
forall (r :: * -> *) p. GDatatype r => r p -> Constructors r p
gUnwrap (a -> Rep a (ZonkAny 0)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
x))
{-# INLINE genericToYaml #-}

-- The encoder takes the default for 'omitNullFields': it leaves out a null
-- field only if the default of the field is null without comments too.
-- Otherwise the decoder would fill the missing key from the default, and the
-- value would not read back.
gToYaml
  :: forall f p
   . ( GConstructors f
     , GToConstructor f
     )
  => YamlOptions -> SumEncodingKind -> Maybe (f p) -> f p -> S.Node
gToYaml :: forall {k} (f :: k -> *) (p :: k).
(GConstructors f, GToConstructor f) =>
YamlOptions -> SumEncodingKind -> Maybe (f p) -> f p -> Node
gToYaml YamlOptions
opts SumEncodingKind
enc Maybe (f p)
def f p
x
  | forall {k} (f :: k). GConstructors f => Bool
forall (f :: k -> *). GConstructors f => Bool
gNullary @f = Value -> Node
scalar (Text -> Value
String (YamlOptions -> f p -> Text
forall (p :: k). YamlOptions -> f p -> Text
forall {k} (f :: k -> *) (p :: k).
GToConstructor f =>
YamlOptions -> f p -> Text
gTag YamlOptions
opts f p
x))
  | Bool
otherwise = YamlOptions -> Maybe SumEncodingKind -> Maybe (f p) -> f p -> Node
forall (p :: k).
YamlOptions -> Maybe SumEncodingKind -> Maybe (f p) -> f p -> Node
forall {k} (f :: k -> *) (p :: k).
GToConstructor f =>
YamlOptions -> Maybe SumEncodingKind -> Maybe (f p) -> f p -> Node
gToConstructor YamlOptions
opts (if forall {k} (f :: k). GConstructors f => YamlOptions -> Bool
forall (f :: k -> *). GConstructors f => YamlOptions -> Bool
isTagged @f YamlOptions
opts then SumEncodingKind -> Maybe SumEncodingKind
forall a. a -> Maybe a
Just SumEncodingKind
enc else Maybe SumEncodingKind
forall a. Maybe a
Nothing) Maybe (f p)
def f p
x
-- Without the pragma, GHC 9.2 does not inline this function, and GHC 9.4 does
-- not inline it for an enumeration. Then the inspection tests of these
-- derived encoders fail. Later versions inline it anyway.
{-# INLINE gToYaml #-}

-- | The encoder of the constructors of a representation.
class GToConstructor f where
  gTag :: YamlOptions -> f p -> T.Text

  -- | The constructor, with the tag in the given encoding.
  gToConstructor :: YamlOptions -> Maybe SumEncodingKind -> Maybe (f p) -> f p -> S.Node

  -- | The mapping entry under the key of a constructor without a tag, if it
  -- has one field without a name. The field gets the key, e.g. for the
  -- comments above the key of a 'Yamlet.Commented' field.
  gToUntaggedEntry :: S.Node -> f p -> Maybe (S.Node, S.Node)

instance GToConstructor V1 where
  gTag :: forall (p :: k). YamlOptions -> V1 p -> Text
gTag YamlOptions
_ = \case {}

  gToConstructor :: forall (p :: k).
YamlOptions
-> Maybe SumEncodingKind -> Maybe (V1 p) -> V1 p -> Node
gToConstructor YamlOptions
_ Maybe SumEncodingKind
_ Maybe (V1 p)
_ = \case {}

  gToUntaggedEntry :: forall (p :: k). Node -> V1 p -> Maybe (Node, Node)
gToUntaggedEntry Node
_ = \case {}

instance (GToConstructor f, GToConstructor g) => GToConstructor (f :+: g) where
  gTag :: forall (p :: k). YamlOptions -> (:+:) f g p -> Text
gTag YamlOptions
opts = \case
    L1 f p
x -> YamlOptions -> f p -> Text
forall (p :: k). YamlOptions -> f p -> Text
forall {k} (f :: k -> *) (p :: k).
GToConstructor f =>
YamlOptions -> f p -> Text
gTag YamlOptions
opts f p
x
    R1 g p
x -> YamlOptions -> g p -> Text
forall (p :: k). YamlOptions -> g p -> Text
forall {k} (f :: k -> *) (p :: k).
GToConstructor f =>
YamlOptions -> f p -> Text
gTag YamlOptions
opts g p
x
  {-# INLINE gTag #-}

  gToConstructor :: forall (p :: k).
YamlOptions
-> Maybe SumEncodingKind
-> Maybe ((:+:) f g p)
-> (:+:) f g p
-> Node
gToConstructor YamlOptions
opts Maybe SumEncodingKind
flat Maybe ((:+:) f g p)
def = \case
    L1 f p
x -> YamlOptions -> Maybe SumEncodingKind -> Maybe (f p) -> f p -> Node
forall (p :: k).
YamlOptions -> Maybe SumEncodingKind -> Maybe (f p) -> f p -> Node
forall {k} (f :: k -> *) (p :: k).
GToConstructor f =>
YamlOptions -> Maybe SumEncodingKind -> Maybe (f p) -> f p -> Node
gToConstructor YamlOptions
opts Maybe SumEncodingKind
flat (Maybe ((:+:) f g p) -> Maybe (f p)
forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:+:) f g p) -> Maybe (f p)
leftDefault Maybe ((:+:) f g p)
def) f p
x
    R1 g p
x -> YamlOptions -> Maybe SumEncodingKind -> Maybe (g p) -> g p -> Node
forall (p :: k).
YamlOptions -> Maybe SumEncodingKind -> Maybe (g p) -> g p -> Node
forall {k} (f :: k -> *) (p :: k).
GToConstructor f =>
YamlOptions -> Maybe SumEncodingKind -> Maybe (f p) -> f p -> Node
gToConstructor YamlOptions
opts Maybe SumEncodingKind
flat (Maybe ((:+:) f g p) -> Maybe (g p)
forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:+:) f g p) -> Maybe (g p)
rightDefault Maybe ((:+:) f g p)
def) g p
x
  {-# INLINE gToConstructor #-}

  -- A type with several constructors always has a tag.
  gToUntaggedEntry :: forall (p :: k). Node -> (:+:) f g p -> Maybe (Node, Node)
gToUntaggedEntry Node
_ (:+:) f g p
_ = Maybe (Node, Node)
forall a. Maybe a
Nothing

instance
  ( KnownSymbol name
  , GFields f
  , GToFields f
  )
  => GToConstructor (C1 (MetaCons name fixity isRecord) f)
  where
  gTag :: forall (p :: k).
YamlOptions -> C1 ('MetaCons name fixity isRecord) f p -> Text
gTag YamlOptions
opts C1 ('MetaCons name fixity isRecord) f p
_ = forall (name :: Symbol). KnownSymbol name => YamlOptions -> Text
constructorTagOf @name YamlOptions
opts
  {-# INLINE gTag #-}

  gToConstructor :: forall (p :: k).
YamlOptions
-> Maybe SumEncodingKind
-> Maybe (C1 ('MetaCons name fixity isRecord) f p)
-> C1 ('MetaCons name fixity isRecord) f p
-> Node
gToConstructor YamlOptions
opts Maybe SumEncodingKind
tagging Maybe (C1 ('MetaCons name fixity isRecord) f p)
def c :: C1 ('MetaCons name fixity isRecord) f p
c@(M1 f p
x) = case Maybe SumEncodingKind
tagging of
    Just SumEncodingKind
SingleField
      | forall {k} (f :: k). GFields f => Bool
forall (f :: k -> *). GFields f => Bool
gNamed @f ->
          [(Node, Node)] -> Node
mapping [(Text -> Node
string (YamlOptions -> C1 ('MetaCons name fixity isRecord) f p -> Text
forall (p :: k).
YamlOptions -> C1 ('MetaCons name fixity isRecord) f p -> Text
forall {k} (f :: k -> *) (p :: k).
GToConstructor f =>
YamlOptions -> f p -> Text
gTag YamlOptions
opts C1 ('MetaCons name fixity isRecord) f p
c), [(Node, Node)] -> Node
mapping (YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
forall (p :: k).
YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
forall {k} (f :: k -> *) (p :: k).
GToFields f =>
YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
gToEntries YamlOptions
opts (C1 ('MetaCons name fixity isRecord) f p -> f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (C1 ('MetaCons name fixity isRecord) f p -> f p)
-> Maybe (C1 ('MetaCons name fixity isRecord) f p) -> Maybe (f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (C1 ('MetaCons name fixity isRecord) f p)
def) f p
x))]
      | Bool
otherwise -> case f p -> Maybe Node
forall (p :: k). f p -> Maybe Node
forall {k} (f :: k -> *) (p :: k). GToFields f => f p -> Maybe Node
gToValue f p
x of
          Maybe Node
Nothing -> Text -> Node
string (YamlOptions -> C1 ('MetaCons name fixity isRecord) f p -> Text
forall (p :: k).
YamlOptions -> C1 ('MetaCons name fixity isRecord) f p -> Text
forall {k} (f :: k -> *) (p :: k).
GToConstructor f =>
YamlOptions -> f p -> Text
gTag YamlOptions
opts C1 ('MetaCons name fixity isRecord) f p
c)
          Just Node
_ -> [(Node, Node)] -> Node
mapping [Node -> f p -> (Node, Node)
forall (p :: k). Node -> f p -> (Node, Node)
forall {k} (f :: k -> *) (p :: k).
GToFields f =>
Node -> f p -> (Node, Node)
gToEntry (Text -> Node
string (YamlOptions -> C1 ('MetaCons name fixity isRecord) f p -> Text
forall (p :: k).
YamlOptions -> C1 ('MetaCons name fixity isRecord) f p -> Text
forall {k} (f :: k -> *) (p :: k).
GToConstructor f =>
YamlOptions -> f p -> Text
gTag YamlOptions
opts C1 ('MetaCons name fixity isRecord) f p
c)) f p
x]
    Just SumEncodingKind
enc
      | forall {k} (f :: k). GFields f => Bool
forall (f :: k -> *). GFields f => Bool
gNamed @f -> [(Node, Node)] -> Node
mapping ([(Node, Node)] -> [(Node, Node)]
withTagEntry (YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
forall (p :: k).
YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
forall {k} (f :: k -> *) (p :: k).
GToFields f =>
YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
gToEntries YamlOptions
opts (C1 ('MetaCons name fixity isRecord) f p -> f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (C1 ('MetaCons name fixity isRecord) f p -> f p)
-> Maybe (C1 ('MetaCons name fixity isRecord) f p) -> Maybe (f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (C1 ('MetaCons name fixity isRecord) f p)
def) f p
x))
      | Bool
otherwise -> case f p -> Maybe Node
forall (p :: k). f p -> Maybe Node
forall {k} (f :: k -> *) (p :: k). GToFields f => f p -> Maybe Node
gToValue f p
x of
          Maybe Node
Nothing -> [(Node, Node)] -> Node
mapping ([(Node, Node)] -> [(Node, Node)]
withTagEntry [])
          Just Node
v
            | SumEncodingKind
enc SumEncodingKind -> SumEncodingKind -> Bool
forall a. Eq a => a -> a -> Bool
== SumEncodingKind
TaggedFlat
            , Just [(Node, Node)]
entries <- Node -> Maybe [(Node, Node)]
flatEntries Node
v ->
                [(Node, Node)] -> Node
mapping ([(Node, Node)] -> [(Node, Node)]
withTagEntry [(Node, Node)]
entries)
            | Bool
otherwise -> [(Node, Node)] -> Node
mapping ([(Node, Node)] -> [(Node, Node)]
withTagEntry [Node -> f p -> (Node, Node)
forall (p :: k). Node -> f p -> (Node, Node)
forall {k} (f :: k -> *) (p :: k).
GToFields f =>
Node -> f p -> (Node, Node)
gToEntry (Text -> Node
string YamlOptions
opts.contentsKey) f p
x])
    Maybe SumEncodingKind
Nothing
      | forall {k} (f :: k). GFields f => Bool
forall (f :: k -> *). GFields f => Bool
gNamed @f -> [(Node, Node)] -> Node
mapping (YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
forall (p :: k).
YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
forall {k} (f :: k -> *) (p :: k).
GToFields f =>
YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
gToEntries YamlOptions
opts (C1 ('MetaCons name fixity isRecord) f p -> f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (C1 ('MetaCons name fixity isRecord) f p -> f p)
-> Maybe (C1 ('MetaCons name fixity isRecord) f p) -> Maybe (f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (C1 ('MetaCons name fixity isRecord) f p)
def) f p
x)
      | Bool
otherwise -> Node -> Maybe Node -> Node
forall a. a -> Maybe a -> a
fromMaybe ([(Node, Node)] -> Node
mapping []) (f p -> Maybe Node
forall (p :: k). f p -> Maybe Node
forall {k} (f :: k -> *) (p :: k). GToFields f => f p -> Maybe Node
gToValue f p
x)
    where
      withTagEntry :: [(S.Node, S.Node)] -> [(S.Node, S.Node)]
      withTagEntry :: [(Node, Node)] -> [(Node, Node)]
withTagEntry [(Node, Node)]
entries = (YamlOptions
opts.tagKey Text -> Text -> (Node, Node)
forall a. ToYaml a => Text -> a -> (Node, Node)
.= YamlOptions -> C1 ('MetaCons name fixity isRecord) f p -> Text
forall (p :: k).
YamlOptions -> C1 ('MetaCons name fixity isRecord) f p -> Text
forall {k} (f :: k -> *) (p :: k).
GToConstructor f =>
YamlOptions -> f p -> Text
gTag YamlOptions
opts C1 ('MetaCons name fixity isRecord) f p
c) (Node, Node) -> [(Node, Node)] -> [(Node, Node)]
forall a. a -> [a] -> [a]
: [(Node, Node)]
entries

      -- The entries of a field next to the tag, if the decoder can read them
      -- back. The field must be a mapping with a key, and no key can be the
      -- tag key or the contents key. The decoder reads a mapping with the
      -- contents key as the other form. A mapping with an anchor or a tag
      -- keeps it under the contents key, because an alias elsewhere can refer
      -- to the anchor, and the tag is part of the value.
      flatEntries :: S.Node -> Maybe [(S.Node, S.Node)]
      flatEntries :: Node -> Maybe [(Node, Node)]
flatEntries Node
v = case Node
v.content of
        S.MappingContent CollectionStyle
_ [(Node, Node)]
kvs
          | [(Node, Node)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Node, Node)]
kvs -> Maybe [(Node, Node)]
forall a. Maybe a
Nothing
          | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Node
v.props.anchor -> Maybe [(Node, Node)]
forall a. Maybe a
Nothing
          | Node
v.props.tag Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
/= Tag
S.NoTag -> Maybe [(Node, Node)]
forall a. Maybe a
Nothing
          | ((Node, Node) -> Bool) -> [(Node, Node)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Node
k, Node
_) -> Text -> Node -> Bool
isKey YamlOptions
opts.tagKey Node
k Bool -> Bool -> Bool
|| Text -> Node -> Bool
isKey YamlOptions
opts.contentsKey Node
k) [(Node, Node)]
kvs ->
              Maybe [(Node, Node)]
forall a. Maybe a
Nothing
          | Bool
otherwise -> [(Node, Node)] -> Maybe [(Node, Node)]
forall a. a -> Maybe a
Just [(Node, Node)]
kvs
        Content
_ -> Maybe [(Node, Node)]
forall a. Maybe a
Nothing
  {-# INLINE gToConstructor #-}

  gToUntaggedEntry :: forall (p :: k).
Node
-> C1 ('MetaCons name fixity isRecord) f p -> Maybe (Node, Node)
gToUntaggedEntry Node
k (M1 f p
x)
    | forall {k} (f :: k). GFields f => Bool
forall (f :: k -> *). GFields f => Bool
gNamed @f Bool -> Bool -> Bool
|| forall {k} (f :: k). GFields f => Int
forall (f :: k -> *). GFields f => Int
gArity @f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe (Node, Node)
forall a. Maybe a
Nothing
    | Bool
otherwise = (Node, Node) -> Maybe (Node, Node)
forall a. a -> Maybe a
Just (Node -> f p -> (Node, Node)
forall (p :: k). Node -> f p -> (Node, Node)
forall {k} (f :: k -> *) (p :: k).
GToFields f =>
Node -> f p -> (Node, Node)
gToEntry Node
k f p
x)

-- | The encoder of the fields of a constructor.
--
-- The shape check allows named fields, no fields, or one field without a
-- name. The default methods are for the kind of fields that never calls
-- them.
class GToFields f where
  -- | The entries of the named fields, with the given default.
  gToEntries :: YamlOptions -> Maybe (f p) -> f p -> [(S.Node, S.Node)]
  gToEntries YamlOptions
_ Maybe (f p)
_ f p
_ = []

  -- | The value of the only field without a name.
  gToValue :: f p -> Maybe S.Node
  gToValue f p
_ = Maybe Node
forall a. Maybe a
Nothing

  -- | The mapping entry of the only field without a name under the key, e.g.
  -- with the comments of a 'Yamlet.Commented' field on the contents key.
  gToEntry :: S.Node -> f p -> (S.Node, S.Node)
  gToEntry Node
k f p
x = (Node
k, Node -> Maybe Node -> Node
forall a. a -> Maybe a -> a
fromMaybe ([(Node, Node)] -> Node
mapping []) (f p -> Maybe Node
forall (p :: k). f p -> Maybe Node
forall {k} (f :: k -> *) (p :: k). GToFields f => f p -> Maybe Node
gToValue f p
x))

instance GToFields U1

instance (GToFields f, GToFields g) => GToFields (f :*: g) where
  gToEntries :: forall (p :: k).
YamlOptions -> Maybe ((:*:) f g p) -> (:*:) f g p -> [(Node, Node)]
gToEntries YamlOptions
opts Maybe ((:*:) f g p)
def (f p
a :*: g p
b) =
    YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
forall (p :: k).
YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
forall {k} (f :: k -> *) (p :: k).
GToFields f =>
YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
gToEntries YamlOptions
opts (Maybe ((:*:) f g p) -> Maybe (f p)
forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:*:) f g p) -> Maybe (f p)
firstDefault Maybe ((:*:) f g p)
def) f p
a [(Node, Node)] -> [(Node, Node)] -> [(Node, Node)]
forall a. [a] -> [a] -> [a]
++ YamlOptions -> Maybe (g p) -> g p -> [(Node, Node)]
forall (p :: k).
YamlOptions -> Maybe (g p) -> g p -> [(Node, Node)]
forall {k} (f :: k -> *) (p :: k).
GToFields f =>
YamlOptions -> Maybe (f p) -> f p -> [(Node, Node)]
gToEntries YamlOptions
opts (Maybe ((:*:) f g p) -> Maybe (g p)
forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:*:) f g p) -> Maybe (g p)
secondDefault Maybe ((:*:) f g p)
def) g p
b
  {-# INLINE gToEntries #-}

instance
  ( KnownSymbol name
  , ToYaml a
  )
  => GToFields (S1 (MetaSel (Just name) u s d) (Rec0 a))
  where
  gToEntries :: forall (p :: k).
YamlOptions
-> Maybe (S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
-> S1 ('MetaSel ('Just name) u s d) (Rec0 a) p
-> [(Node, Node)]
gToEntries YamlOptions
opts Maybe (S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
def (M1 (K1 a
x))
    | YamlOptions
opts.omitNullFields
        Bool -> Bool -> Bool
&& Node -> Bool
isNullNode ((Node, Node) -> Node
forall a b. (a, b) -> b
snd (Node, Node)
entry)
        Bool -> Bool -> Bool
&& Bool
uncommented
        Bool -> Bool -> Bool
&& Bool
unanchored
        Bool -> Bool -> Bool
&& Bool
nullDefault =
        []
    | Bool
otherwise = [(Node, Node)
entry]
    where
      entry :: (S.Node, S.Node)
      entry :: (Node, Node)
entry = forall (name :: Symbol). KnownSymbol name => YamlOptions -> Text
fieldKey @name YamlOptions
opts Text -> a -> (Node, Node)
forall a. ToYaml a => Text -> a -> (Node, Node)
.= a
x

      -- The comments would go away with the entry.
      uncommented :: Bool
      uncommented :: Bool
uncommented =
        ((Node, Node) -> Node
forall a b. (a, b) -> a
fst (Node, Node)
entry).comments Comments -> Comments -> Bool
forall a. Eq a => a -> a -> Bool
== Comments
S.noComments Bool -> Bool -> Bool
&& ((Node, Node) -> Node
forall a b. (a, b) -> b
snd (Node, Node)
entry).comments Comments -> Comments -> Bool
forall a. Eq a => a -> a -> Bool
== Comments
S.noComments

      -- An alias elsewhere can refer to the anchor.
      unanchored :: Bool
      unanchored :: Bool
unanchored = Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing ((Node, Node) -> Node
forall a b. (a, b) -> b
snd (Node, Node)
entry).props.anchor

      -- The decoder fills a missing key from the default.
      nullDefault :: Bool
      nullDefault :: Bool
nullDefault = case Maybe (S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
def of
        Just (M1 (K1 a
d)) -> a -> Bool
forall a. ToYaml a => a -> Bool
isNullDefault a
d
        Maybe (S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
Nothing -> Bool
True
  {-# INLINE gToEntries #-}

-- | The field of a default is null without comments, and not
-- 'requiredField'.
isNullDefault :: ToYaml a => a -> Bool
isNullDefault :: forall a. ToYaml a => a -> Bool
isNullDefault a
d = case a -> Node
forall a. ToYaml a => a -> Node
toYaml (a -> Node) -> Maybe a -> Maybe Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe a
forall a. a -> Maybe a
defaultField a
d of
  Just Node
n -> Node -> Bool
isNullNode Node
n Bool -> Bool -> Bool
&& Node
n.comments Comments -> Comments -> Bool
forall a. Eq a => a -> a -> Bool
== Comments
S.noComments
  Maybe Node
Nothing -> Bool
False
-- Not inlined, the call has only constant arguments, so GHC computes it once
-- for each field of a default. Inlined in the encoder, as in the @where@
-- clause of its caller, it ran on each encode, and the encode of records with
-- a default and 'omitNullFields' was slower and allocated more.
{-# NOINLINE isNullDefault #-}

instance ToYaml a => GToFields (S1 (MetaSel Nothing u s d) (Rec0 a)) where
  gToValue :: forall (p :: k).
S1 ('MetaSel 'Nothing u s d) (Rec0 a) p -> Maybe Node
gToValue (M1 (K1 a
x)) = Node -> Maybe Node
forall a. a -> Maybe a
Just (a -> Node
forall a. ToYaml a => a -> Node
toYaml a
x)

  gToEntry :: forall (p :: k).
Node -> S1 ('MetaSel 'Nothing u s d) (Rec0 a) p -> (Node, Node)
gToEntry Node
k (M1 (K1 a
x)) = Node -> a -> (Node, Node)
forall a. ToYaml a => Node -> a -> (Node, Node)
toYamlField Node
k a
x

----------------------------------------
-- Decoding

-- | The generic decoder, e.g. for an instance by hand with a check after the
-- decode.
--
-- >>> :{
-- data Range = Range {low :: Int, high :: Int}
--   deriving stock (Generic, Show)
--   deriving anyclass (GenericYamlOptions)
-- instance FromYaml Range where
--   parseYaml n = do
--     r <- genericParseYaml n
--     if r.low <= r.high then pure r else failAt n "expected low <= high"
-- :}
--
-- >>> decodeText @Range "low: 1\nhigh: 2\n"
-- Right (Range {low = 1, high = 2})
--
-- >>> either printErrors print (decodeText @Range "low: 3\nhigh: 2\n")
-- input.yaml:1:1: expected low <= high
--   |
-- 1 | low: 3
--   | ^

-- The code inlines in the derived method, for the reasons at 'genericToYaml'.
genericParseYaml
  :: forall a f
   . ( Generic a
     , GenericYamlOptions a
     , GDatatype (Rep a)
     , Constructors (Rep a) ~ f
     , GConstructors f
     , GEncoding (SumEncoding a) f
     , GFromConstructor f
     )
  => S.Node -> Parser a
genericParseYaml :: forall a (f :: * -> *).
(Generic a, GenericYamlOptions a, GDatatype (Rep a),
 Constructors (Rep a) ~ f, GConstructors f,
 GEncoding (SumEncoding a) f, GFromConstructor f) =>
Node -> Parser a
genericParseYaml Node
n =
  -- Forcing the encoding forces the check of the shape, e.g. with deferred
  -- type errors in a test of the errors.
  let enc :: SumEncodingKind
enc = forall {k} (e :: SumEncodingKind) (f :: k).
GEncoding e f =>
SumEncodingKind
forall (e :: SumEncodingKind) (f :: * -> *).
GEncoding e f =>
SumEncodingKind
gEncoding @(SumEncoding a) @f
  in SumEncodingKind
enc
       SumEncodingKind -> Parser a -> Parser a
forall a b. a -> b -> b
`seq` forall a. (GenericYamlOptions a, GDatatype (Rep a)) => ()
checkDefault @a
       () -> Parser a -> Parser a
forall a b. a -> b -> b
`seq` YamlOptions
-> SumEncodingKind
-> Maybe (Constructors (Rep a) (ZonkAny 1))
-> (Constructors (Rep a) (ZonkAny 1) -> a)
-> Node
-> Parser a
forall {k} (f :: k -> *) (p :: k) a.
(GConstructors f, GFromConstructor f) =>
YamlOptions
-> SumEncodingKind -> Maybe (f p) -> (f p -> a) -> Node -> Parser a
gParseYaml
         (forall a. GenericYamlOptions a => YamlOptions
yamlOptions @a)
         SumEncodingKind
enc
         (Rep a (ZonkAny 1) -> Constructors (Rep a) (ZonkAny 1)
forall p. Rep a p -> Constructors (Rep a) p
forall (r :: * -> *) p. GDatatype r => r p -> Constructors r p
gUnwrap (Rep a (ZonkAny 1) -> Constructors (Rep a) (ZonkAny 1))
-> (a -> Rep a (ZonkAny 1))
-> a
-> Constructors (Rep a) (ZonkAny 1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a (ZonkAny 1)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from (a -> Constructors (Rep a) (ZonkAny 1))
-> Maybe a -> Maybe (Constructors (Rep a) (ZonkAny 1))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenericYamlOptions a => Maybe a
yamlDefault @a)
         (Rep a (ZonkAny 1) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a (ZonkAny 1) -> a)
-> (Constructors (Rep a) (ZonkAny 1) -> Rep a (ZonkAny 1))
-> Constructors (Rep a) (ZonkAny 1)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constructors (Rep a) (ZonkAny 1) -> Rep a (ZonkAny 1)
forall p. Constructors (Rep a) p -> Rep a p
forall (r :: * -> *) p. GDatatype r => Constructors r p -> r p
gWrap)
         Node
n
{-# INLINE genericParseYaml #-}

-- Each constructor applies 'to' to its own representation, e.g.
-- @to (M1 (L1 (M1 fields)))@, and the optimizer reduces this to the real
-- constructor in the same place. For this, the decoders of the constructors
-- take a continuation. It starts as 'to' after 'gWrap' and grows by 'M1',
-- 'L1' or 'R1' at each level of the sum.
--
-- In the direct style, each constructor returns its representation, the
-- branches meet in 'mplus', and 'to' comes after them. The optimizer then no
-- longer knows which branch produced the value, so the program builds 'L1',
-- 'R1' and ':*:' at run time and 'to' matches on them again.
--
-- The fields of one constructor need no continuation, because they build
-- their product in one place, and 'to' of the same branch consumes it.
--
-- The representation of the default goes down with the options, so that each
-- field finds its default value.
gParseYaml
  :: forall f p a
   . ( GConstructors f
     , GFromConstructor f
     )
  => YamlOptions -> SumEncodingKind -> Maybe (f p) -> (f p -> a) -> S.Node -> Parser a
gParseYaml :: forall {k} (f :: k -> *) (p :: k) a.
(GConstructors f, GFromConstructor f) =>
YamlOptions
-> SumEncodingKind -> Maybe (f p) -> (f p -> a) -> Node -> Parser a
gParseYaml YamlOptions
opts SumEncodingKind
enc Maybe (f p)
def f p -> a
k Node
n
  | forall {k} (f :: k). GConstructors f => Bool
forall (f :: k -> *). GConstructors f => Bool
gNullary @f =
      [Text] -> (Text -> Parser a) -> Node -> Parser a
forall a. [Text] -> (Text -> Parser a) -> Node -> Parser a
withName [Text]
tags (\Text
t -> Parser a -> Maybe (Parser a) -> Parser a
forall a. a -> Maybe a -> a
fromMaybe (Node -> String -> Text -> Parser a
unknown Node
n String
"value" Text
t) (YamlOptions -> (f p -> a) -> Node -> Text -> Maybe (Parser a)
forall (p :: k) a.
YamlOptions -> (f p -> a) -> Node -> Text -> Maybe (Parser a)
forall {k} (f :: k -> *) (p :: k) a.
GFromConstructor f =>
YamlOptions -> (f p -> a) -> Node -> Text -> Maybe (Parser a)
gFromTag YamlOptions
opts f p -> a
k Node
n Text
t)) Node
n
  | forall {k} (f :: k). GConstructors f => YamlOptions -> Bool
forall (f :: k -> *). GConstructors f => YamlOptions -> Bool
isTagged @f YamlOptions
opts, SumEncodingKind
enc SumEncodingKind -> SumEncodingKind -> Bool
forall a. Eq a => a -> a -> Bool
== SumEncodingKind
SingleField = Parser a
single
  | forall {k} (f :: k). GConstructors f => YamlOptions -> Bool
forall (f :: k -> *). GConstructors f => YamlOptions -> Bool
isTagged @f YamlOptions
opts = (Object -> Parser a) -> Node -> Parser a
forall a. (Object -> Parser a) -> Node -> Parser a
withMapping Object -> Parser a
tagged Node
n
  | Bool
otherwise = YamlOptions -> Maybe (f p) -> (f p -> a) -> Node -> Parser a
forall (p :: k) a.
YamlOptions -> Maybe (f p) -> (f p -> a) -> Node -> Parser a
forall {k} (f :: k -> *) (p :: k) a.
GFromConstructor f =>
YamlOptions -> Maybe (f p) -> (f p -> a) -> Node -> Parser a
gFromUntagged YamlOptions
opts Maybe (f p)
def f p -> a
k Node
n
  where
    tagged :: Object -> Parser a
    tagged :: Object -> Parser a
tagged Object
o = case Text -> Map Text (Node, Node) -> Maybe (Node, Node)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup YamlOptions
opts.tagKey Object
o.index of
      Maybe (Node, Node)
Nothing -> Object -> Text -> Parser a
forall a. Object -> Text -> Parser a
missingKey Object
o YamlOptions
opts.tagKey
      Just (Node
_, Node
tn) -> do
        t <- [Text] -> (Text -> Parser Text) -> Node -> Parser Text
forall a. [Text] -> (Text -> Parser a) -> Node -> Parser a
withName [Text]
tags Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Node
tn
        fromMaybe (unknown tn "tag" t) (gFromTagged opts (enc == TaggedFlat) def k t o)

    -- A constructor without fields is its tag, and another constructor is a
    -- mapping with its tag as the only key.
    single :: Parser a
    single :: Parser a
single = case Node -> View
view Node
n of
      StringView Text
t -> Parser a -> Maybe (Parser a) -> Parser a
forall a. a -> Maybe a -> a
fromMaybe (Text -> Parser a
withoutValue Text
t) (YamlOptions -> (f p -> a) -> Node -> Text -> Maybe (Parser a)
forall (p :: k) a.
YamlOptions -> (f p -> a) -> Node -> Text -> Maybe (Parser a)
forall {k} (f :: k -> *) (p :: k) a.
GFromConstructor f =>
YamlOptions -> (f p -> a) -> Node -> Text -> Maybe (Parser a)
gFromTag YamlOptions
opts f p -> a
k Node
n Text
t)
      View
_ | S.MappingContent {} <- Node
n.content -> (Object -> Parser a) -> Node -> Parser a
forall a. (Object -> Parser a) -> Node -> Parser a
withMapping Object -> Parser a
singleEntry Node
n
      View
_ | Just String
msg <- [Text] -> Node -> Maybe String
unquotedName [Text]
tags Node
n -> Node -> String -> Parser a
forall a. Node -> String -> Parser a
failAt Node
n String
msg
      View
_ -> String -> Node -> Parser a
forall a. String -> Node -> Parser a
typeMismatch String
"a string or a mapping with one key" Node
n

    singleEntry :: Object -> Parser a
    singleEntry :: Object -> Parser a
singleEntry Object
o = case Object -> [(Node, Node)]
objectEntries Object
o of
      [(Node
kn, Node
v)] -> do
        t <- [Text] -> (Text -> Parser Text) -> Node -> Parser Text
forall a. [Text] -> (Text -> Parser a) -> Node -> Parser a
withName [Text]
tags Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Node
kn
        fromMaybe (unknown kn "constructor" t) (gFromSingle opts def k t (kn, v))
      (Node, Node)
_ : (Node
kn, Node
_) : [(Node, Node)]
_ -> Node -> String -> Parser a
forall a. Node -> String -> Parser a
failAt Node
kn String
"expected a mapping with one key, but got a second key"
      [] -> Node -> String -> Parser a
forall a. Node -> String -> Parser a
failAt Node
n String
"expected a mapping with one key, but got an empty mapping"

    -- A string that is the tag of a constructor with fields.
    withoutValue :: T.Text -> Parser a
    withoutValue :: Text -> Parser a
withoutValue Text
t
      | Text
t Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
tags =
          Node -> String -> Parser a
forall a. Node -> String -> Parser a
failAt Node
n (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$
            String
"expected a mapping with the key "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
showText Text
t
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", because the constructor has fields"
      | Bool
otherwise = Node -> String -> Text -> Parser a
unknown Node
n String
"constructor" Text
t

    unknown :: S.Node -> String -> T.Text -> Parser a
    unknown :: Node -> String -> Text -> Parser a
unknown Node
node String
what = String -> [Text] -> Node -> Text -> Parser a
forall a. String -> [Text] -> Node -> Text -> Parser a
unknownName String
what [Text]
tags Node
node

    tags :: [T.Text]
    tags :: [Text]
tags = (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (YamlOptions -> String -> Text
constructorTag YamlOptions
opts) (forall {k} (f :: k). GConstructors f => [String]
forall (f :: k -> *). GConstructors f => [String]
gConstructorNames @f)
{-# INLINE gParseYaml #-}

-- | The decoder of the constructors of a representation.
class GFromConstructor f where
  -- | The constructor without fields with the tag, from the node of the tag.
  gFromTag :: YamlOptions -> (f p -> a) -> S.Node -> T.Text -> Maybe (Parser a)

  -- | The constructor with the tag, from the mapping that holds the tag, with
  -- the flag of 'TaggedFlat'.
  gFromTagged
    :: YamlOptions
    -> Bool
    -> Maybe (f p)
    -> (f p -> a)
    -> T.Text
    -> Object
    -> Maybe (Parser a)

  -- | The constructor with the tag, from the only entry of a mapping, for
  -- 'SingleField'.
  gFromSingle
    :: YamlOptions
    -> Maybe (f p)
    -> (f p -> a)
    -> T.Text
    -> (S.Node, S.Node)
    -> Maybe (Parser a)

  -- | The only constructor, without a tag.
  gFromUntagged :: YamlOptions -> Maybe (f p) -> (f p -> a) -> S.Node -> Parser a

  -- | The only constructor, without a tag, from a mapping entry, if it has
  -- one field without a name. The field gets the key, e.g. for the comments
  -- above the key of a 'Yamlet.Commented' field.
  gFromUntaggedEntry :: (f p -> a) -> (S.Node, S.Node) -> Maybe (Parser a)

instance GFromConstructor V1 where
  gFromTag :: forall (p :: k) a.
YamlOptions -> (V1 p -> a) -> Node -> Text -> Maybe (Parser a)
gFromTag YamlOptions
_ V1 p -> a
_ Node
_ Text
_ = Maybe (Parser a)
forall a. Maybe a
Nothing

  gFromTagged :: forall (p :: k) a.
YamlOptions
-> Bool
-> Maybe (V1 p)
-> (V1 p -> a)
-> Text
-> Object
-> Maybe (Parser a)
gFromTagged YamlOptions
_ Bool
_ Maybe (V1 p)
_ V1 p -> a
_ Text
_ Object
_ = Maybe (Parser a)
forall a. Maybe a
Nothing

  gFromSingle :: forall (p :: k) a.
YamlOptions
-> Maybe (V1 p)
-> (V1 p -> a)
-> Text
-> (Node, Node)
-> Maybe (Parser a)
gFromSingle YamlOptions
_ Maybe (V1 p)
_ V1 p -> a
_ Text
_ (Node, Node)
_ = Maybe (Parser a)
forall a. Maybe a
Nothing

  gFromUntagged :: forall (p :: k) a.
YamlOptions -> Maybe (V1 p) -> (V1 p -> a) -> Node -> Parser a
gFromUntagged YamlOptions
_ Maybe (V1 p)
_ V1 p -> a
_ Node
_ = String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected a type with constructors"

  gFromUntaggedEntry :: forall (p :: k) a. (V1 p -> a) -> (Node, Node) -> Maybe (Parser a)
gFromUntaggedEntry V1 p -> a
_ (Node, Node)
_ = Maybe (Parser a)
forall a. Maybe a
Nothing

instance (GFromConstructor f, GFromConstructor g) => GFromConstructor (f :+: g) where
  gFromTag :: forall (p :: k) a.
YamlOptions
-> ((:+:) f g p -> a) -> Node -> Text -> Maybe (Parser a)
gFromTag YamlOptions
opts (:+:) f g p -> a
k Node
n Text
t = YamlOptions -> (f p -> a) -> Node -> Text -> Maybe (Parser a)
forall (p :: k) a.
YamlOptions -> (f p -> a) -> Node -> Text -> Maybe (Parser a)
forall {k} (f :: k -> *) (p :: k) a.
GFromConstructor f =>
YamlOptions -> (f p -> a) -> Node -> Text -> Maybe (Parser a)
gFromTag YamlOptions
opts ((:+:) f g p -> a
k ((:+:) f g p -> a) -> (f p -> (:+:) f g p) -> f p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1) Node
n Text
t Maybe (Parser a) -> Maybe (Parser a) -> Maybe (Parser a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` YamlOptions -> (g p -> a) -> Node -> Text -> Maybe (Parser a)
forall (p :: k) a.
YamlOptions -> (g p -> a) -> Node -> Text -> Maybe (Parser a)
forall {k} (f :: k -> *) (p :: k) a.
GFromConstructor f =>
YamlOptions -> (f p -> a) -> Node -> Text -> Maybe (Parser a)
gFromTag YamlOptions
opts ((:+:) f g p -> a
k ((:+:) f g p -> a) -> (g p -> (:+:) f g p) -> g p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1) Node
n Text
t
  {-# INLINE gFromTag #-}

  gFromTagged :: forall (p :: k) a.
YamlOptions
-> Bool
-> Maybe ((:+:) f g p)
-> ((:+:) f g p -> a)
-> Text
-> Object
-> Maybe (Parser a)
gFromTagged YamlOptions
opts Bool
flat Maybe ((:+:) f g p)
def (:+:) f g p -> a
k Text
t Object
o =
    YamlOptions
-> Bool
-> Maybe (f p)
-> (f p -> a)
-> Text
-> Object
-> Maybe (Parser a)
forall (p :: k) a.
YamlOptions
-> Bool
-> Maybe (f p)
-> (f p -> a)
-> Text
-> Object
-> Maybe (Parser a)
forall {k} (f :: k -> *) (p :: k) a.
GFromConstructor f =>
YamlOptions
-> Bool
-> Maybe (f p)
-> (f p -> a)
-> Text
-> Object
-> Maybe (Parser a)
gFromTagged YamlOptions
opts Bool
flat (Maybe ((:+:) f g p) -> Maybe (f p)
forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:+:) f g p) -> Maybe (f p)
leftDefault Maybe ((:+:) f g p)
def) ((:+:) f g p -> a
k ((:+:) f g p -> a) -> (f p -> (:+:) f g p) -> f p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1) Text
t Object
o
      Maybe (Parser a) -> Maybe (Parser a) -> Maybe (Parser a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` YamlOptions
-> Bool
-> Maybe (g p)
-> (g p -> a)
-> Text
-> Object
-> Maybe (Parser a)
forall (p :: k) a.
YamlOptions
-> Bool
-> Maybe (g p)
-> (g p -> a)
-> Text
-> Object
-> Maybe (Parser a)
forall {k} (f :: k -> *) (p :: k) a.
GFromConstructor f =>
YamlOptions
-> Bool
-> Maybe (f p)
-> (f p -> a)
-> Text
-> Object
-> Maybe (Parser a)
gFromTagged YamlOptions
opts Bool
flat (Maybe ((:+:) f g p) -> Maybe (g p)
forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:+:) f g p) -> Maybe (g p)
rightDefault Maybe ((:+:) f g p)
def) ((:+:) f g p -> a
k ((:+:) f g p -> a) -> (g p -> (:+:) f g p) -> g p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1) Text
t Object
o
  {-# INLINE gFromTagged #-}

  gFromSingle :: forall (p :: k) a.
YamlOptions
-> Maybe ((:+:) f g p)
-> ((:+:) f g p -> a)
-> Text
-> (Node, Node)
-> Maybe (Parser a)
gFromSingle YamlOptions
opts Maybe ((:+:) f g p)
def (:+:) f g p -> a
k Text
t (Node, Node)
entry =
    YamlOptions
-> Maybe (f p)
-> (f p -> a)
-> Text
-> (Node, Node)
-> Maybe (Parser a)
forall (p :: k) a.
YamlOptions
-> Maybe (f p)
-> (f p -> a)
-> Text
-> (Node, Node)
-> Maybe (Parser a)
forall {k} (f :: k -> *) (p :: k) a.
GFromConstructor f =>
YamlOptions
-> Maybe (f p)
-> (f p -> a)
-> Text
-> (Node, Node)
-> Maybe (Parser a)
gFromSingle YamlOptions
opts (Maybe ((:+:) f g p) -> Maybe (f p)
forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:+:) f g p) -> Maybe (f p)
leftDefault Maybe ((:+:) f g p)
def) ((:+:) f g p -> a
k ((:+:) f g p -> a) -> (f p -> (:+:) f g p) -> f p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1) Text
t (Node, Node)
entry
      Maybe (Parser a) -> Maybe (Parser a) -> Maybe (Parser a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` YamlOptions
-> Maybe (g p)
-> (g p -> a)
-> Text
-> (Node, Node)
-> Maybe (Parser a)
forall (p :: k) a.
YamlOptions
-> Maybe (g p)
-> (g p -> a)
-> Text
-> (Node, Node)
-> Maybe (Parser a)
forall {k} (f :: k -> *) (p :: k) a.
GFromConstructor f =>
YamlOptions
-> Maybe (f p)
-> (f p -> a)
-> Text
-> (Node, Node)
-> Maybe (Parser a)
gFromSingle YamlOptions
opts (Maybe ((:+:) f g p) -> Maybe (g p)
forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:+:) f g p) -> Maybe (g p)
rightDefault Maybe ((:+:) f g p)
def) ((:+:) f g p -> a
k ((:+:) f g p -> a) -> (g p -> (:+:) f g p) -> g p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1) Text
t (Node, Node)
entry
  {-# INLINE gFromSingle #-}

  -- A type with several constructors always has a tag.
  gFromUntagged :: forall (p :: k) a.
YamlOptions
-> Maybe ((:+:) f g p) -> ((:+:) f g p -> a) -> Node -> Parser a
gFromUntagged YamlOptions
_ Maybe ((:+:) f g p)
_ (:+:) f g p -> a
_ Node
_ = String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected a tag"

  gFromUntaggedEntry :: forall (p :: k) a.
((:+:) f g p -> a) -> (Node, Node) -> Maybe (Parser a)
gFromUntaggedEntry (:+:) f g p -> a
_ (Node, Node)
_ = Maybe (Parser a)
forall a. Maybe a
Nothing

instance
  ( KnownSymbol name
  , GFields f
  , GFromFields f
  )
  => GFromConstructor (C1 (MetaCons name fixity isRecord) f)
  where
  gFromTag :: forall (p :: k) a.
YamlOptions
-> (C1 ('MetaCons name fixity isRecord) f p -> a)
-> Node
-> Text
-> Maybe (Parser a)
gFromTag YamlOptions
opts C1 ('MetaCons name fixity isRecord) f p -> a
k Node
n Text
t
    | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tag Bool -> Bool -> Bool
&& forall {k} (f :: k). GFields f => Int
forall (f :: k -> *). GFields f => Int
gArity @f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Parser a -> Maybe (Parser a)
forall a. a -> Maybe a
Just (C1 ('MetaCons name fixity isRecord) f p -> a
k (C1 ('MetaCons name fixity isRecord) f p -> a)
-> (f p -> C1 ('MetaCons name fixity isRecord) f p) -> f p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> C1 ('MetaCons name fixity isRecord) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> a) -> Parser (f p) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser (f p)
forall (p :: k). Node -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
Node -> Parser (f p)
gFromValue Node
n)
    | Bool
otherwise = Maybe (Parser a)
forall a. Maybe a
Nothing
    where
      tag :: T.Text
      tag :: Text
tag = forall (name :: Symbol). KnownSymbol name => YamlOptions -> Text
constructorTagOf @name YamlOptions
opts
  {-# INLINE gFromTag #-}

  gFromTagged :: forall (p :: k) a.
YamlOptions
-> Bool
-> Maybe (C1 ('MetaCons name fixity isRecord) f p)
-> (C1 ('MetaCons name fixity isRecord) f p -> a)
-> Text
-> Object
-> Maybe (Parser a)
gFromTagged YamlOptions
opts Bool
flat Maybe (C1 ('MetaCons name fixity isRecord) f p)
def C1 ('MetaCons name fixity isRecord) f p -> a
k Text
t Object
o
    | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== forall (name :: Symbol). KnownSymbol name => YamlOptions -> Text
constructorTagOf @name YamlOptions
opts =
        Parser a -> Maybe (Parser a)
forall a. a -> Maybe a
Just (C1 ('MetaCons name fixity isRecord) f p -> a
k (C1 ('MetaCons name fixity isRecord) f p -> a)
-> (f p -> C1 ('MetaCons name fixity isRecord) f p) -> f p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> C1 ('MetaCons name fixity isRecord) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> a) -> Parser (f p) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> YamlOptions
-> Bool -> [Text] -> Maybe (f p) -> Object -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
(GFields f, GFromFields f) =>
YamlOptions
-> Bool -> [Text] -> Maybe (f p) -> Object -> Parser (f p)
fromObject YamlOptions
opts Bool
flat [YamlOptions
opts.tagKey] (C1 ('MetaCons name fixity isRecord) f p -> f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (C1 ('MetaCons name fixity isRecord) f p -> f p)
-> Maybe (C1 ('MetaCons name fixity isRecord) f p) -> Maybe (f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (C1 ('MetaCons name fixity isRecord) f p)
def) Object
o)
    | Bool
otherwise = Maybe (Parser a)
forall a. Maybe a
Nothing
  {-# INLINE gFromTagged #-}

  gFromSingle :: forall (p :: k) a.
YamlOptions
-> Maybe (C1 ('MetaCons name fixity isRecord) f p)
-> (C1 ('MetaCons name fixity isRecord) f p -> a)
-> Text
-> (Node, Node)
-> Maybe (Parser a)
gFromSingle YamlOptions
opts Maybe (C1 ('MetaCons name fixity isRecord) f p)
def C1 ('MetaCons name fixity isRecord) f p -> a
k Text
t entry :: (Node, Node)
entry@(Node
kn, Node
v)
    | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= forall (name :: Symbol). KnownSymbol name => YamlOptions -> Text
constructorTagOf @name YamlOptions
opts = Maybe (Parser a)
forall a. Maybe a
Nothing
    | forall {k} (f :: k). GFields f => Bool
forall (f :: k -> *). GFields f => Bool
gNamed @f =
        Parser a -> Maybe (Parser a)
forall a. a -> Maybe a
Just ((Object -> Parser a) -> Node -> Parser a
forall a. (Object -> Parser a) -> Node -> Parser a
withMapping ((f p -> a) -> Parser (f p) -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (C1 ('MetaCons name fixity isRecord) f p -> a
k (C1 ('MetaCons name fixity isRecord) f p -> a)
-> (f p -> C1 ('MetaCons name fixity isRecord) f p) -> f p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> C1 ('MetaCons name fixity isRecord) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) (Parser (f p) -> Parser a)
-> (Object -> Parser (f p)) -> Object -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YamlOptions
-> Bool -> [Text] -> Maybe (f p) -> Object -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
(GFields f, GFromFields f) =>
YamlOptions
-> Bool -> [Text] -> Maybe (f p) -> Object -> Parser (f p)
fromObject YamlOptions
opts Bool
False [] (C1 ('MetaCons name fixity isRecord) f p -> f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (C1 ('MetaCons name fixity isRecord) f p -> f p)
-> Maybe (C1 ('MetaCons name fixity isRecord) f p) -> Maybe (f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (C1 ('MetaCons name fixity isRecord) f p)
def)) Node
v)
    | forall {k} (f :: k). GFields f => Int
forall (f :: k -> *). GFields f => Int
gArity @f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
        Parser a -> Maybe (Parser a)
forall a. a -> Maybe a
Just (Parser a -> Maybe (Parser a))
-> (String -> Parser a) -> String -> Maybe (Parser a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> String -> Parser a
forall a. Node -> String -> Parser a
failAt Node
kn (String -> Maybe (Parser a)) -> String -> Maybe (Parser a)
forall a b. (a -> b) -> a -> b
$
          String
"expected the string "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
showText Text
t
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", because the constructor has no fields"
    | Bool
otherwise = Parser a -> Maybe (Parser a)
forall a. a -> Maybe a
Just (C1 ('MetaCons name fixity isRecord) f p -> a
k (C1 ('MetaCons name fixity isRecord) f p -> a)
-> (f p -> C1 ('MetaCons name fixity isRecord) f p) -> f p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> C1 ('MetaCons name fixity isRecord) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> a) -> Parser (f p) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node, Node) -> Parser (f p)
forall (p :: k). (Node, Node) -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
(Node, Node) -> Parser (f p)
gFromEntry (Node, Node)
entry)
  {-# INLINE gFromSingle #-}

  gFromUntagged :: forall (p :: k) a.
YamlOptions
-> Maybe (C1 ('MetaCons name fixity isRecord) f p)
-> (C1 ('MetaCons name fixity isRecord) f p -> a)
-> Node
-> Parser a
gFromUntagged YamlOptions
opts Maybe (C1 ('MetaCons name fixity isRecord) f p)
def C1 ('MetaCons name fixity isRecord) f p -> a
k Node
n
    | forall {k} (f :: k). GFields f => Bool
forall (f :: k -> *). GFields f => Bool
gNamed @f Bool -> Bool -> Bool
|| forall {k} (f :: k). GFields f => Int
forall (f :: k -> *). GFields f => Int
gArity @f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
        (Object -> Parser a) -> Node -> Parser a
forall a. (Object -> Parser a) -> Node -> Parser a
withMapping ((f p -> a) -> Parser (f p) -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (C1 ('MetaCons name fixity isRecord) f p -> a
k (C1 ('MetaCons name fixity isRecord) f p -> a)
-> (f p -> C1 ('MetaCons name fixity isRecord) f p) -> f p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> C1 ('MetaCons name fixity isRecord) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) (Parser (f p) -> Parser a)
-> (Object -> Parser (f p)) -> Object -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YamlOptions
-> Bool -> [Text] -> Maybe (f p) -> Object -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
(GFields f, GFromFields f) =>
YamlOptions
-> Bool -> [Text] -> Maybe (f p) -> Object -> Parser (f p)
fromObject YamlOptions
opts Bool
False [] (C1 ('MetaCons name fixity isRecord) f p -> f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (C1 ('MetaCons name fixity isRecord) f p -> f p)
-> Maybe (C1 ('MetaCons name fixity isRecord) f p) -> Maybe (f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (C1 ('MetaCons name fixity isRecord) f p)
def)) Node
n
    | Bool
otherwise = C1 ('MetaCons name fixity isRecord) f p -> a
k (C1 ('MetaCons name fixity isRecord) f p -> a)
-> (f p -> C1 ('MetaCons name fixity isRecord) f p) -> f p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> C1 ('MetaCons name fixity isRecord) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> a) -> Parser (f p) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser (f p)
forall (p :: k). Node -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
Node -> Parser (f p)
gFromValue Node
n
  {-# INLINE gFromUntagged #-}

  gFromUntaggedEntry :: forall (p :: k) a.
(C1 ('MetaCons name fixity isRecord) f p -> a)
-> (Node, Node) -> Maybe (Parser a)
gFromUntaggedEntry C1 ('MetaCons name fixity isRecord) f p -> a
k (Node, Node)
entry
    | forall {k} (f :: k). GFields f => Bool
forall (f :: k -> *). GFields f => Bool
gNamed @f Bool -> Bool -> Bool
|| forall {k} (f :: k). GFields f => Int
forall (f :: k -> *). GFields f => Int
gArity @f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe (Parser a)
forall a. Maybe a
Nothing
    | Bool
otherwise = Parser a -> Maybe (Parser a)
forall a. a -> Maybe a
Just (C1 ('MetaCons name fixity isRecord) f p -> a
k (C1 ('MetaCons name fixity isRecord) f p -> a)
-> (f p -> C1 ('MetaCons name fixity isRecord) f p) -> f p -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> C1 ('MetaCons name fixity isRecord) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> a) -> Parser (f p) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node, Node) -> Parser (f p)
forall (p :: k). (Node, Node) -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
(Node, Node) -> Parser (f p)
gFromEntry (Node, Node)
entry)

-- | The fields of a constructor from a mapping. The given keys, e.g. the tag
-- key, are no fields but valid keys.
fromObject
  :: forall f p
   . ( GFields f
     , GFromFields f
     )
  => YamlOptions -> Bool -> [T.Text] -> Maybe (f p) -> Object -> Parser (f p)
fromObject :: forall {k} (f :: k -> *) (p :: k).
(GFields f, GFromFields f) =>
YamlOptions
-> Bool -> [Text] -> Maybe (f p) -> Object -> Parser (f p)
fromObject YamlOptions
opts Bool
flat [Text]
keys Maybe (f p)
def Object
o
  | forall {k} (f :: k). GFields f => Bool
forall (f :: k -> *). GFields f => Bool
gNamed @f Bool -> Bool -> Bool
|| forall {k} (f :: k). GFields f => Int
forall (f :: k -> *). GFields f => Int
gArity @f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [Text] -> Parser (f p) -> Parser (f p)
checked (forall {k} (f :: k). GFields f => YamlOptions -> [Text]
forall (f :: k -> *). GFields f => YamlOptions -> [Text]
gNames @f YamlOptions
opts) (YamlOptions -> Maybe (f p) -> Object -> Parser (f p)
forall (p :: k).
YamlOptions -> Maybe (f p) -> Object -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
YamlOptions -> Maybe (f p) -> Object -> Parser (f p)
gFromObject YamlOptions
opts Maybe (f p)
def Object
o)
  | Bool
flat
  , Bool -> Bool
not ([(Node, Node)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Node, Node)]
others)
  , Bool -> Bool
not (((Node, Node) -> Bool) -> [(Node, Node)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Node -> Bool
isKey YamlOptions
opts.contentsKey (Node -> Bool) -> ((Node, Node) -> Node) -> (Node, Node) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, Node) -> Node
forall a b. (a, b) -> a
fst) [(Node, Node)]
others) =
      Parser (f p)
merged
  | Bool
otherwise = [Text] -> Parser (f p) -> Parser (f p)
checked [YamlOptions
opts.contentsKey] (Parser (f p) -> Parser (f p)) -> Parser (f p) -> Parser (f p)
forall a b. (a -> b) -> a -> b
$ case Text -> Map Text (Node, Node) -> Maybe (Node, Node)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup YamlOptions
opts.contentsKey Object
o.index of
      Just (Node, Node)
entry -> (Node, Node) -> Parser (f p)
forall (p :: k). (Node, Node) -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
(Node, Node) -> Parser (f p)
gFromEntry (Node, Node)
entry
      -- A missing contents key is null, if the fields accept null. A flat
      -- field can also have only optional keys. A flat field has no key to
      -- require.
      Maybe (Node, Node)
Nothing
        | Just f p
fields <- f p -> Maybe (f p)
forall (p :: k). f p -> Maybe (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
f p -> Maybe (f p)
gDefaultValue (f p -> Maybe (f p)) -> Maybe (f p) -> Maybe (f p)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (f p)
def -> f p -> Parser (f p)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f p
fields
        | Maybe (f p) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (f p)
def, Bool -> Bool
not Bool
flat -> Object -> Text -> Parser (f p)
forall a. Object -> Text -> Parser a
missingKey Object
o YamlOptions
opts.contentsKey
        | Bool
flat -> Parser (f p)
-> (f p -> Parser (f p)) -> Maybe (f p) -> Parser (f p)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parser (f p)
onlyTag f p -> Parser (f p)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Node -> Parser (f p)) -> Node -> Maybe (f p)
forall a. (Node -> Parser a) -> Node -> Maybe a
succeeds Node -> Parser (f p)
forall (p :: k). Node -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
Node -> Parser (f p)
gFromValue Node
nullNode)
        | Bool
otherwise ->
            Parser (f p)
-> (f p -> Parser (f p)) -> Maybe (f p) -> Parser (f p)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Object -> Text -> Parser (f p)
forall a. Object -> Text -> Parser a
missingKey Object
o YamlOptions
opts.contentsKey) f p -> Parser (f p)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Node -> Parser (f p)) -> Node -> Maybe (f p)
forall a. (Node -> Parser a) -> Node -> Maybe a
succeeds Node -> Parser (f p)
forall (p :: k). Node -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
Node -> Parser (f p)
gFromValue Node
nullNode)
  where
    -- The fields, with the errors of the unknown keys if the options reject
    -- them.
    checked :: [T.Text] -> Parser (f p) -> Parser (f p)
    checked :: [Text] -> Parser (f p) -> Parser (f p)
checked [Text]
fields =
      (Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when YamlOptions
opts.rejectUnknownFields ([Text] -> Object -> Parser ()
rejectUnknownKeys ([Text]
keys [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
fields) Object
o) Parser () -> Parser (f p) -> Parser (f p)
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>)

    -- A mapping with only the tag gives the field an empty mapping. Its error
    -- does not show that, so a note at the tag says it. Each error of the
    -- field is at the mapping, because the empty mapping has no other nodes.
    onlyTag :: Parser (f p)
    onlyTag :: Parser (f p)
onlyTag =
      Offset -> (Offset, String) -> Parser (f p) -> Parser (f p)
forall a. Offset -> (Offset, String) -> Parser a -> Parser a
withNote
        (Object -> Node
objectNode Object
o).offset
        ( Offset -> (Node -> Offset) -> Maybe Node -> Offset
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Offset
S.noOffset (.offset) Maybe Node
tag
        , String
"the mapping has no key "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
showText YamlOptions
opts.contentsKey
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and no other keys for the field of "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Node -> String) -> Maybe Node -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Node -> String
constructorName Maybe Node
tag
        )
        Parser (f p)
merged
      where
        tag :: Maybe S.Node
        tag :: Maybe Node
tag = (Node, Node) -> Node
forall a b. (a, b) -> b
snd ((Node, Node) -> Node) -> Maybe (Node, Node) -> Maybe Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text (Node, Node) -> Maybe (Node, Node)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup YamlOptions
opts.tagKey Object
o.index

        constructorName :: S.Node -> String
        constructorName :: Node -> String
constructorName Node
n = case Node
n.content of
          S.ScalarContent ScalarStyle
_ Text
t -> Text -> String
T.unpack Text
t
          Content
_ -> String
""

    -- The field decodes from the mapping without the given keys, and without
    -- the comments, the tag and the anchor of the mapping. The record drops
    -- the comments, and the tag and the anchor belong to the value of the
    -- sum type, as with 'TaggedObject'.
    merged :: Parser (f p)
    merged :: Parser (f p)
merged =
      let n :: Node
n = Object -> Node
objectNode Object
o
          style :: CollectionStyle
style = case Node
n.content of
            S.MappingContent CollectionStyle
s [(Node, Node)]
_ -> CollectionStyle
s
            Content
_ -> CollectionStyle
S.Block
      in Node -> Parser (f p)
forall (p :: k). Node -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
Node -> Parser (f p)
gFromValue (Node -> Parser (f p)) -> Node -> Parser (f p)
forall a b. (a -> b) -> a -> b
$
           S.Node
             { offset :: Offset
S.offset = Node
n.offset
             , endOffset :: Offset
S.endOffset = Node
n.endOffset
             , props :: Props
S.props = Props
S.noProps
             , comments :: Comments
S.comments = Comments
S.noComments
             , content :: Content
S.content = CollectionStyle -> [(Node, Node)] -> Content
S.MappingContent CollectionStyle
style [(Node, Node)]
others
             }

    -- The duplicates of a key go too. The mapping has their errors, and a
    -- field of a recursive type would give them again at each level.
    others :: [(S.Node, S.Node)]
    others :: [(Node, Node)]
others
      | Object
o.duplicates = ((Node, Node) -> Bool) -> [(Node, Node)] -> [(Node, Node)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Node
k, Node
_) -> Bool -> Bool
not ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Node -> Bool
`isKey` Node
k) [Text]
keys)) (Object -> [(Node, Node)]
objectEntries Object
o)
      | Bool
otherwise = (Text -> [(Node, Node)] -> [(Node, Node)])
-> [(Node, Node)] -> [Text] -> [(Node, Node)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> [(Node, Node)] -> [(Node, Node)]
removeKey (Object -> [(Node, Node)]
objectEntries Object
o) [Text]
keys

    -- The keys are unique, so the entries after the match stay shared.
    removeKey :: T.Text -> [(S.Node, S.Node)] -> [(S.Node, S.Node)]
    removeKey :: Text -> [(Node, Node)] -> [(Node, Node)]
removeKey Text
key = \case
      kv :: (Node, Node)
kv@(Node
k, Node
_) : [(Node, Node)]
kvs
        | Text -> Node -> Bool
isKey Text
key Node
k -> [(Node, Node)]
kvs
        | Bool
otherwise -> (Node, Node)
kv (Node, Node) -> [(Node, Node)] -> [(Node, Node)]
forall a. a -> [a] -> [a]
: Text -> [(Node, Node)] -> [(Node, Node)]
removeKey Text
key [(Node, Node)]
kvs
      [] -> []
{-# INLINE fromObject #-}

-- | The decoder of the fields of a constructor.
--
-- The shape check allows named fields, no fields, or one field without a
-- name. The default methods are for the kind of fields that never calls
-- them.
class GFromFields f where
  -- | The fields from a mapping, with the given default for missing keys.
  gFromObject :: YamlOptions -> Maybe (f p) -> Object -> Parser (f p)
  gFromObject YamlOptions
_ Maybe (f p)
_ Object
o =
    String -> Parser (f p)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (f p)) -> String -> Parser (f p)
forall a b. (a -> b) -> a -> b
$ String
"expected a field without a name in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
describeNode (Object -> Node
objectNode Object
o)

  -- | The only field without a name from its value.
  gFromValue :: S.Node -> Parser (f p)
  gFromValue Node
n = String -> Parser (f p)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (f p)) -> String -> Parser (f p)
forall a b. (a -> b) -> a -> b
$ String
"expected named fields in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
describeNode Node
n

  -- | The only field from a mapping entry, with the key, e.g. for the
  -- comments of a 'Yamlet.Commented' field under the contents key.
  gFromEntry :: (S.Node, S.Node) -> Parser (f p)
  gFromEntry (Node
_, Node
v) = Node -> Parser (f p)
forall (p :: k). Node -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
Node -> Parser (f p)
gFromValue Node
v

  -- | The only field without a name from a default, or 'Nothing' for
  -- 'requiredField'.
  gDefaultValue :: f p -> Maybe (f p)
  gDefaultValue = f p -> Maybe (f p)
forall a. a -> Maybe a
Just

-- The value of a constructor without fields is its tag.
instance GFromFields U1 where
  gFromObject :: forall (p :: k).
YamlOptions -> Maybe (U1 p) -> Object -> Parser (U1 p)
gFromObject YamlOptions
_ Maybe (U1 p)
_ Object
_ = U1 p -> Parser (U1 p)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 p
forall k (p :: k). U1 p
U1

  gFromValue :: forall (p :: k). Node -> Parser (U1 p)
gFromValue Node
_ = U1 p -> Parser (U1 p)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 p
forall k (p :: k). U1 p
U1

instance (GFromFields f, GFromFields g) => GFromFields (f :*: g) where
  gFromObject :: forall (p :: k).
YamlOptions
-> Maybe ((:*:) f g p) -> Object -> Parser ((:*:) f g p)
gFromObject YamlOptions
opts Maybe ((:*:) f g p)
def Object
o =
    f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
      (f p -> g p -> (:*:) f g p)
-> Parser (f p) -> Parser (g p -> (:*:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> YamlOptions -> Maybe (f p) -> Object -> Parser (f p)
forall (p :: k).
YamlOptions -> Maybe (f p) -> Object -> Parser (f p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
YamlOptions -> Maybe (f p) -> Object -> Parser (f p)
gFromObject YamlOptions
opts (Maybe ((:*:) f g p) -> Maybe (f p)
forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:*:) f g p) -> Maybe (f p)
firstDefault Maybe ((:*:) f g p)
def) Object
o
      Parser (g p -> (:*:) f g p) -> Parser (g p) -> Parser ((:*:) f g p)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> YamlOptions -> Maybe (g p) -> Object -> Parser (g p)
forall (p :: k).
YamlOptions -> Maybe (g p) -> Object -> Parser (g p)
forall {k} (f :: k -> *) (p :: k).
GFromFields f =>
YamlOptions -> Maybe (f p) -> Object -> Parser (f p)
gFromObject YamlOptions
opts (Maybe ((:*:) f g p) -> Maybe (g p)
forall {k} (f :: k -> *) (g :: k -> *) (p :: k).
Maybe ((:*:) f g p) -> Maybe (g p)
secondDefault Maybe ((:*:) f g p)
def) Object
o
  {-# INLINE gFromObject #-}

instance
  ( KnownSymbol name
  , FromYaml a
  )
  => GFromFields (S1 (MetaSel (Just name) u s d) (Rec0 a))
  where
  gFromObject :: forall (p :: k).
YamlOptions
-> Maybe (S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
-> Object
-> Parser (S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
gFromObject YamlOptions
opts Maybe (S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
def Object
o =
    Rec0 a p -> S1 ('MetaSel ('Just name) u s d) (Rec0 a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 a p -> S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
-> (a -> Rec0 a p)
-> a
-> S1 ('MetaSel ('Just name) u s d) (Rec0 a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rec0 a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
-> Parser a -> Parser (S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Text -> Map Text (Node, Node) -> Maybe (Node, Node)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Object
o.index of
      Just (Node, Node)
entry -> (Node, Node) -> Parser a
forall a. FromYaml a => (Node, Node) -> Parser a
parseEntry (Node, Node)
entry
      Maybe (Node, Node)
Nothing -> case Maybe (S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
def of
        Just (M1 (K1 a
d))
          | Just a
x <- a -> Maybe a
forall a. a -> Maybe a
defaultField a
d -> a
x a -> Parser (Maybe (Node, Node)) -> Parser a
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Object -> Text -> Parser (Maybe (Node, Node))
findKey Object
o Text
key
          | Bool
otherwise -> Object -> Text -> Parser a
forall a. Object -> Text -> Parser a
missingKey Object
o Text
key
        -- A missing field is null, if its type accepts null.
        Maybe (S1 ('MetaSel ('Just name) u s d) (Rec0 a) p)
Nothing ->
          Parser a -> (a -> Parser a) -> Maybe a -> Parser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Object -> Text -> Parser a
forall a. Object -> Text -> Parser a
missingKey Object
o Text
key) (a -> Parser (Maybe (Node, Node)) -> Parser a
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Object -> Text -> Parser (Maybe (Node, Node))
findKey Object
o Text
key) ((Node -> Parser a) -> Node -> Maybe a
forall a. (Node -> Parser a) -> Node -> Maybe a
succeeds Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml Node
nullNode)
    where
      key :: T.Text
      key :: Text
key = forall (name :: Symbol). KnownSymbol name => YamlOptions -> Text
fieldKey @name YamlOptions
opts
  {-# INLINE gFromObject #-}

instance FromYaml a => GFromFields (S1 (MetaSel Nothing u s d) (Rec0 a)) where
  gFromValue :: forall (p :: k).
Node -> Parser (S1 ('MetaSel 'Nothing u s d) (Rec0 a) p)
gFromValue Node
n = Rec0 a p -> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 a p -> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p)
-> (a -> Rec0 a p)
-> a
-> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rec0 a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p)
-> Parser a -> Parser (M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml Node
n

  gFromEntry :: forall (p :: k).
(Node, Node) -> Parser (S1 ('MetaSel 'Nothing u s d) (Rec0 a) p)
gFromEntry (Node, Node)
entry = Rec0 a p -> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 a p -> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p)
-> (a -> Rec0 a p)
-> a
-> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rec0 a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p)
-> Parser a -> Parser (M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node, Node) -> Parser a
forall a. FromYaml a => (Node, Node) -> Parser a
parseEntry (Node, Node)
entry

  gDefaultValue :: forall (p :: k).
S1 ('MetaSel 'Nothing u s d) (Rec0 a) p
-> Maybe (S1 ('MetaSel 'Nothing u s d) (Rec0 a) p)
gDefaultValue (M1 (K1 a
x)) = K1 R a p -> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R a p -> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p)
-> (a -> K1 R a p)
-> a
-> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 R a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p)
-> Maybe a -> Maybe (M1 S ('MetaSel 'Nothing u s d) (Rec0 a) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe a
forall a. a -> Maybe a
defaultField a
x

-- | The key is a string with the text.
isKey :: T.Text -> S.Node -> Bool
isKey :: Text -> Node -> Bool
isKey Text
key Node
k = case Node -> Maybe Text
stringValue Node
k of
  Just Text
t -> Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
key
  Maybe Text
_ -> Bool
False

-- $setup
-- >>> import Data.Text qualified as T
-- >>> import Data.Text.IO qualified as T
-- >>> import Yamlet
-- >>> printErrors = mapM_ (putStrLn . prettyError "input.yaml")