    {-# LANGUAGE AllowAmbiguousTypes  #-}
    {-# LANGUAGE DataKinds            #-}
    {-# LANGUAGE FlexibleContexts     #-}
    {-# LANGUAGE PolyKinds            #-}
    {-# LANGUAGE ScopedTypeVariables  #-}
    {-# LANGUAGE TypeApplications     #-}
    {-# LANGUAGE TypeOperators        #-}
    {-# LANGUAGE TypeSynonymInstances #-}
    {-# LANGUAGE UndecidableInstances #-}

    {-| Newtypes for writing customizable 'FromDhall' and 'ToDhall' instances
        through the DerivingVia strategy.

        Inspired by Matt Parson's blog post
        [Mirror Mirror: Reflection and Encoding Via](https://www.parsonsmatt.org/2020/02/04/mirror_mirror.html),
        but applied to Dhall instead of JSON.

        This module is intended to be used with
        [DerivingVia](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-DerivingVia)
        so it's only available for GHC >= v8.6.1.

        Check the section /Letting DerivingVia do the work/ if you want to see this module in action. (Click "Dhall.Deriving#derivingVia" to jump there)

    -}

    module Dhall.Deriving
      (
        -- * Introduction
        -- $introduction

        -- * Writing FromDhall instances by hand
        -- $instancesByHand

        -- * Letting DerivingVia do the work
        -- $derivingVia

        -- * Behind the scenes of Codec
        -- $behindTheScenes

        -- * DerivingVia newtype
        Codec (..)

        -- * Type-level functions on InterpretOptions
      , ModifyOptions (..)
      , Field
      , Constructor
      , SetSingletonConstructors

        -- * Type-level functions on Text
      , TextFunction (..)
      , DropPrefix
      , TitleCase
      , CamelCase
      , PascalCase
      , SnakeCase
      , SpinalCase
      , TrainCase

        -- * Type-level versions of SingletonConstructors
      , ToSingletonConstructors(..)
      , Bare
      , Wrapped
      , Smart

        -- * Identity and Composition for ModifyOptions and TextFunction
      , AsIs
      , type (<<<)

        -- * Helper function on Text
      , dropPrefix

        -- * InterpretOptions setters
      , addFieldModifier
      , addConstructorModifier
      , setSingletonConstructors

      ) where

    import Data.Proxy   (Proxy (..))
    import Dhall
    import GHC.Generics (Generic (Rep))
    import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)

    import qualified Data.Text            as Text
    import qualified Data.Text.Manipulate as Case

    -- | Intended for use on @deriving via@ clauses for types with a
    --   'Generic' instance. The @tag@ argument is used to construct an
    --   'InterpretOptions' value which is used as the first argument
    --   to 'genericAutoWith'.
    newtype Codec tag a = Codec { forall {k} (tag :: k) a. Codec tag a -> a
    unCodec :: a }

    instance (Generic a, GenericFromDhall a (Rep a), ModifyOptions tag) => FromDhall (Codec tag a) where
      autoWith :: InputNormalizer -> Decoder (Codec tag a)
    autoWith InputNormalizer
    _ = a -> Codec tag a
    forall {k} (tag :: k) a. a -> Codec tag a
    Codec (a -> Codec tag a) -> Decoder a -> Decoder (Codec tag a)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> InterpretOptions -> Decoder a
    forall a.
    (Generic a, GenericFromDhall a (Rep a)) =>
    InterpretOptions -> Decoder a
    genericAutoWith (forall (a :: k).
    ModifyOptions a =>
    InterpretOptions -> InterpretOptions
    forall {k} (a :: k).
    ModifyOptions a =>
    InterpretOptions -> InterpretOptions
    modifyOptions @tag InterpretOptions
    defaultInterpretOptions)

    instance (Generic a, GenericToDhall (Rep a), ModifyOptions tag) => ToDhall (Codec tag a) where
      injectWith :: InputNormalizer -> Encoder (Codec tag a)
    injectWith InputNormalizer
    _ = Codec tag a -> a
    forall {k} (tag :: k) a. Codec tag a -> a
    unCodec (Codec tag a -> a) -> Encoder a -> Encoder (Codec tag a)
    forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
    >$< InterpretOptions -> Encoder a
    forall a.
    (Generic a, GenericToDhall (Rep a)) =>
    InterpretOptions -> Encoder a
    genericToDhallWith (forall (a :: k).
    ModifyOptions a =>
    InterpretOptions -> InterpretOptions
    forall {k} (a :: k).
    ModifyOptions a =>
    InterpretOptions -> InterpretOptions
    modifyOptions @tag InterpretOptions
    defaultInterpretOptions)

    -- | Convert a type into a @InterpretOptions -> InterpretOptions@ function
    class ModifyOptions a where
      modifyOptions :: InterpretOptions -> InterpretOptions

    -- | The identity for functions on 'InterpretOptions' and on @Text@.
    --   Useful for deriving @FromDhall@ and @ToDhall@ with the default options.
    type AsIs = ()

    instance ModifyOptions AsIs where
      modifyOptions :: InterpretOptions -> InterpretOptions
    modifyOptions = InterpretOptions -> InterpretOptions
    forall a. a -> a
    id

    instance TextFunction AsIs where
      textFunction :: Text -> Text
    textFunction = Text -> Text
    forall a. a -> a
    id

    -- | Composition for functions on 'InterpretOptions' and on @Text@.
    --   We use @<<<@ since @.@ isn't a valid type operator yet
    --   (it will be valid starting from ghc-8.8.1)
    data a <<< b
    infixr 1 <<<

    instance (ModifyOptions a, ModifyOptions b) => ModifyOptions (a <<< b) where
      modifyOptions :: InterpretOptions -> InterpretOptions
    modifyOptions = forall (a :: k).
    ModifyOptions a =>
    InterpretOptions -> InterpretOptions
    forall {k} (a :: k).
    ModifyOptions a =>
    InterpretOptions -> InterpretOptions
    modifyOptions @a (InterpretOptions -> InterpretOptions)
    -> (InterpretOptions -> InterpretOptions)
    -> InterpretOptions
    -> InterpretOptions
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall (a :: k).
    ModifyOptions a =>
    InterpretOptions -> InterpretOptions
    forall {k} (a :: k).
    ModifyOptions a =>
    InterpretOptions -> InterpretOptions
    modifyOptions @b

    instance (TextFunction a, TextFunction b) => TextFunction (a <<< b) where
      textFunction :: Text -> Text
    textFunction = forall (a :: k). TextFunction a => Text -> Text
    forall {k} (a :: k). TextFunction a => Text -> Text
    textFunction @a (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall (a :: k). TextFunction a => Text -> Text
    forall {k} (a :: k). TextFunction a => Text -> Text
    textFunction @b

    -- | @Field t@ post-composes the @fieldModifier@ from @options@ with the
    --   value-level version of @t@, obtained with @TextFunction@
    data Field a
    instance TextFunction a => ModifyOptions (Field a) where
      modifyOptions :: InterpretOptions -> InterpretOptions
    modifyOptions = (Text -> Text) -> InterpretOptions -> InterpretOptions
    addFieldModifier (forall (a :: k). TextFunction a => Text -> Text
    forall {k} (a :: k). TextFunction a => Text -> Text
    textFunction @a)

    -- | @Constructor t@ post-composes the @constructorModifier@ from @options@
    --   with the value-level version of @t@, obtained with @TextFunction@
    data Constructor a
    instance TextFunction a => ModifyOptions (Constructor a) where
      modifyOptions :: InterpretOptions -> InterpretOptions
    modifyOptions = (Text -> Text) -> InterpretOptions -> InterpretOptions
    addConstructorModifier (forall (a :: k). TextFunction a => Text -> Text
    forall {k} (a :: k). TextFunction a => Text -> Text
    textFunction @a)

    -- * Text Functions

    -- | Convert a type into a @Text -> Text@ function
    class TextFunction a where
      textFunction :: Text -> Text

    -- | @DropPrefix prefix@ corresponds to the value level
    --   function @'dropPrefix' prefix@
    data DropPrefix (s :: Symbol)
    instance KnownSymbol s => TextFunction (DropPrefix s) where
      textFunction :: Text -> Text
    textFunction = Text -> Text -> Text
    dropPrefix (String -> Text
    Text.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
    KnownSymbol n =>
    proxy n -> String
    symbolVal @s Proxy s
    forall {k} (t :: k). Proxy t
    Proxy))

    -- | Convert casing to @Title Cased Phrase@
    data TitleCase
    instance TextFunction TitleCase where
      textFunction :: Text -> Text
    textFunction = Text -> Text
    Case.toTitle

    -- | Convert casing to @camelCasedPhrase@
    data CamelCase
    instance TextFunction CamelCase where
      textFunction :: Text -> Text
    textFunction = Text -> Text
    Case.toCamel

    -- | Convert casing to @PascalCasedPhrase@
    data PascalCase
    instance TextFunction PascalCase where
      textFunction :: Text -> Text
    textFunction = Text -> Text
    Case.toPascal

    -- | Convert casing to @snake_cased_phrase@
    data SnakeCase
    instance TextFunction SnakeCase where
      textFunction :: Text -> Text
    textFunction = Text -> Text
    Case.toSnake

    -- | Convert casing to @spinal-cased-phrase@
    data SpinalCase
    instance TextFunction SpinalCase where
      textFunction :: Text -> Text
    textFunction = Text -> Text
    Case.toSpinal

    -- | Convert casing to @Train-Cased-Phrase@
    data TrainCase
    instance TextFunction TrainCase where
      textFunction :: Text -> Text
    textFunction = Text -> Text
    Case.toTrain

    -- | @SetSingletonConstructors t@ replaces the @singletonConstructors@
    --  from @options@ with the value-level version of @t@.
    data SetSingletonConstructors a
    instance ToSingletonConstructors a => ModifyOptions (SetSingletonConstructors a) where
      modifyOptions :: InterpretOptions -> InterpretOptions
    modifyOptions = SingletonConstructors -> InterpretOptions -> InterpretOptions
    setSingletonConstructors (forall (a :: SingletonConstructors).
    ToSingletonConstructors a =>
    SingletonConstructors
    asSingletonConstructors @a)

    -- | Convert a type of kind @SingletonConstructors@
    --   into a value of type @SingletonConstructors@
    class ToSingletonConstructors (a :: SingletonConstructors) where
      asSingletonConstructors :: SingletonConstructors

    -- | Type-level version of 'Dhall.Bare'.
    -- Never wrap the field of a singleton constructor in a record
    type Bare = 'Bare
    instance ToSingletonConstructors Bare where
      asSingletonConstructors :: SingletonConstructors
    asSingletonConstructors = SingletonConstructors
    Bare

    -- | Type-level version of 'Dhall.Wrapped'
    -- Always wrap the field of a singleton constructor in a record
    type Wrapped = 'Wrapped
    instance ToSingletonConstructors Wrapped where
      asSingletonConstructors :: SingletonConstructors
    asSingletonConstructors = SingletonConstructors
    Wrapped

    -- | Type-level version of 'Dhall.Smart'
    -- Wrap the field of a singleton constructor in a record
    -- only if the field is named
    type Smart = 'Smart
    instance ToSingletonConstructors Smart where
      asSingletonConstructors :: SingletonConstructors
    asSingletonConstructors = SingletonConstructors
    Smart

    -- * Text helper

    -- | @dropPrefix prefix text@ returns the suffix of @text@ if its prefix
    --   matches @prefix@, or the entire @text@ otherwise
    dropPrefix :: Text -> (Text -> Text)
    dropPrefix :: Text -> Text -> Text
    dropPrefix Text
    prefix Text
    text = case Text -> Text -> Maybe Text
    Text.stripPrefix Text
    prefix Text
    text of
      Maybe Text
    Nothing -> Text
    text
      Just Text
    e -> Text
    e

    -- * InterpretOptions setters

    -- | @addFieldModifier f options@ post-composes the @fieldModifier@
    --  from @options@ with @f@.
    addFieldModifier :: (Text -> Text) -> InterpretOptions -> InterpretOptions
    addFieldModifier :: (Text -> Text) -> InterpretOptions -> InterpretOptions
    addFieldModifier Text -> Text
    f InterpretOptions
    options = InterpretOptions
    options
      { fieldModifier :: Text -> Text
    fieldModifier = Text -> Text
    f (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . InterpretOptions -> Text -> Text
    fieldModifier InterpretOptions
    options }

    -- | @addConstructorModifier f options@ post-composes the @constructorModifier@
    --   from @options@ with @f@.
    addConstructorModifier :: (Text -> Text) -> InterpretOptions -> InterpretOptions
    addConstructorModifier :: (Text -> Text) -> InterpretOptions -> InterpretOptions
    addConstructorModifier Text -> Text
    f InterpretOptions
    options = InterpretOptions
    options
      { constructorModifier :: Text -> Text
    constructorModifier = Text -> Text
    f (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . InterpretOptions -> Text -> Text
    constructorModifier InterpretOptions
    options }

    -- | @setSingletonConstructors v options@ replaces the @singletonConstructors@
    --  from @options@ with @v@.
    setSingletonConstructors :: SingletonConstructors -> InterpretOptions -> InterpretOptions
    setSingletonConstructors :: SingletonConstructors -> InterpretOptions -> InterpretOptions
    setSingletonConstructors SingletonConstructors
    v InterpretOptions
    options = InterpretOptions
    options
      { singletonConstructors :: SingletonConstructors
    singletonConstructors = SingletonConstructors
    v }

    {- $introduction

    Let's take the following Haskell data types:

    >>> :set -XDerivingStrategies

    >>> :{
    newtype Name = Name { getName :: Text }
      deriving stock (Show)
    :}

    >>> :{
    data Font = Arial | ComicSans | Helvetica | TimesNewRoman
      deriving stock (Show)
    :}

    >>> :{
    data Person = Person
      { personName :: Name
      , personFavoriteFont :: Font
      }
      deriving stock (Show)
    :}

    And assume we want to read the following Dhall file as a @Person@:

    @
    -- ./simon.dhall
    let Name = Text
    let Font = \< Arial | `Comic Sans` | Helvetica | `Times New Roman` \>
    let Person = { name : Name, favoriteFont : Font }
    in  { name = \"Simon\", favoriteFont = Font.`Comic Sans` } : Person
    @

    Usually, you would build a 'Decoder' by hand, like this

    >>> :{
    font :: Decoder Font
    font =
      union
        (  (Arial         <$ constructor "Arial"           unit)
        <> (ComicSans     <$ constructor "Comic Sans"      unit)
        <> (Helvetica     <$ constructor "Helvetica"       unit)
        <> (TimesNewRoman <$ constructor "Times New Roman" unit)
        )
    :}

    >>> :{
    name :: Decoder Name
    name = Name <$> strictText
    :}

    >>> :{
    person :: Decoder Person
    person =
      record
        ( Person <$> field "name"         name
                 <*> field "favoriteFont" font
        )
    :}

    and then you use it like this

    >>> input person "./simon.dhall"
    Person {personName = Name {getName = "Simon"}, personFavoriteFont = ComicSans}

    So, it works! However, this is quite mechanic, and the compiler has pretty
    much all the information it needs to do it for you. Besides, you'd like to
    provide an instance of 'FromDhall' so you can use the polymorphic 'Decoder'
    'auto' instead of explicitly calling @person@.
    -}

    {- $instancesByHand
    "Aha!," you think, "I'll write an empty @instance 'FromDhall' Person@".
    That in turn requires you to add two other instances for @Font@ and for @Name@,
    plus 'Generic' instances for each of those, but that's okay.

    >>> :set -XStandaloneDeriving
    >>> :set -XDeriveGeneric

    >>> :{
    deriving stock instance Generic Name
    deriving stock instance Generic Font
    deriving stock instance Generic Person
    :}

    >>> :{
    instance FromDhall Name
    instance FromDhall Font
    instance FromDhall Person
    :}

    However, when you try to read the same file with 'auto', you get this:

    >>> input auto "./simon.dhall" :: IO Person
    *** Exception:
    ...Error...: Expression doesn't match annotation
    ...
    { - personFavoriteFont : …
    , - personName : …
    , + favoriteFont : …
    , + name : …
    }
    ...
    1│ ./simon.dhall : { personName : { getName : Text }
    2│ , personFavoriteFont : < Arial | ComicSans | Helvetica | TimesNewRoman >
    3│ }
    ...

    What happened? The field names don't quite match, since we're using prefixed
    field names in Haskell but no prefixes in Dhall. "Okay," you think,
    "I can write a custom instance which builds on 'Generic' thanks to
    'genericAutoWith', I only need to supply a function to drop the prefixes
    and @camelCase@ the rest". So, using 'Data.Text.Manipulate.toCamel':

    >>> import Data.Text.Manipulate (toCamel)
    >>> import qualified Data.Text as Text
    >>> :{
    instance FromDhall Person where
      autoWith _ =
        genericAutoWith defaultInterpretOptions
          { fieldModifier = toCamel . Text.drop (Text.length "person") }
    :}

    Let's try to read that again:

    >>> input auto "./simon.dhall":: IO Person
    *** Exception:
    ...Error...: Expression doesn't match annotation
    ...
    { favoriteFont : < - ComicSans : …
                     | - TimesNewRoman : …
                     | + `Comic Sans` : …
                     | + `Times New Roman` : …
                     | …
                     >
    , name : - { … : … } (a record type)
             + Text
    }
    ...
    1│ ./simon.dhall : { name : { getName : Text }
    2│ , favoriteFont : < Arial | ComicSans | Helvetica | TimesNewRoman >
    3│ }
    ...

    Okay, we're almost there. We have two things to solve now.
    First, the @Font@ constructors are @PascalCased@ in Haskell,
    but @Title Cased@ in Dhall. We can communicate this to our
    'FromDhall' instance using 'Data.Text.Manipulate.toTitle':

    >>> import Data.Text.Manipulate (toTitle)
    >>> :{
    instance FromDhall Font where
      autoWith _ =
        genericAutoWith defaultInterpretOptions
          { constructorModifier = toTitle }
    :}

    Second, we defined the @Name@ type in Haskell as a newtype over @Text@, with a
    @getName@ field for unwrapping. In Dhall, however, @Name@ is a synonym of
    'Data.Text.Text', which is why 'Dhall.input' above was expecting a record.
    The 'Dhall.Bare' option for 'singletonConstructors' is a perfect fit here:
    it translates Haskell singleton constructors into the Dhall version of the
    nested type, without wrapping it into a record.
    We can then tweak our 'FromDhall' instance like this:

    >>> :{
    instance FromDhall Name where
      autoWith _ =
        genericAutoWith defaultInterpretOptions
          { singletonConstructors = Bare }
    :}

    Since we're running this interactively, we also need to update the
    instance for @Person@, but it's the same as before.

    >>> :{
    instance FromDhall Person where
      autoWith _ =
        genericAutoWith defaultInterpretOptions
          { fieldModifier = toCamel . Text.drop (Text.length "person") }
    :}

    Now, for the moment of truth:

    >>> input auto "./simon.dhall":: IO Person
    Person {personName = Name {getName = "Simon"}, personFavoriteFont = ComicSans}

    That took a bit more work than we wanted, though, and a lot of it was just
    boilerplate for defining the instances through `genericAutoWith`, tweaking
    a single parameter at a time. Even worse, if we also wanted to provide
    'ToDhall' instances we would need to keep the options in sync between both
    instances, since otherwise the values wouldn't be able to round-trip from
    Dhall to Dhall through Haskell.

    -}

    {- $derivingVia
       #derivingVia#

    Starting with this dhall file:

    @
    -- ./simon.dhall
    let Name = Text
    let Font = \< Arial | `Comic Sans` | Helvetica | `Times New Roman` \>
    let Person = { name : Name, favoriteFont : Font }
    in  { name = \"Simon\", favoriteFont = Font.`Comic Sans` } : Person
    @

    We can define the equivalent Haskell types as follows. Note that we
    derive the 'FromDhall' and 'ToDhall' instances @via 'Codec' tag TheType@,
    using a different @tag@ depending on the transformations we need to apply to
    the Haskell type to get the Dhall equivalent:

    >>> :set -XDataKinds
    >>> :set -XDeriveGeneric
    >>> :set -XDerivingVia
    >>> :set -XTypeOperators

    >>> :{
    newtype Name = Name { getName :: Text }
      deriving stock (Generic, Show)
      deriving (FromDhall, ToDhall)
        via Codec (SetSingletonConstructors Bare) Name
    :}

    >>> :{
    data Font = Arial | ComicSans | Helvetica | TimesNewRoman
      deriving stock (Generic, Show)
      deriving (FromDhall, ToDhall)
        via Codec (Constructor TitleCase) Font
    :}

    >>> :{
    data Person = Person
      { personName :: Name
      , personFavoriteFont :: Font
      }
      deriving stock (Generic, Show)
      deriving (FromDhall, ToDhall)
        via Codec (Field (CamelCase <<< DropPrefix "person")) Person
    :}

    we can then read the file using 'auto':

    >>> simon <- input auto "./simon.dhall":: IO Person
    >>> print simon
    Person {personName = Name {getName = "Simon"}, personFavoriteFont = ComicSans}

    And using 'inject' we can get @simon@ back as a Dhall value:

    >>> import qualified Data.Text.IO as Text
    >>> import Dhall.Core (pretty)
    >>> Text.putStrLn . pretty . embed inject $ simon
    { name = "Simon"
    , favoriteFont =
        < Arial | `Comic Sans` | Helvetica | `Times New Roman` >.`Comic Sans`
    }

    -}

    {- $behindTheScenes

    @'Codec' tag a@ is really just a newtype over @a@, equipped with a
    phantom @tag@. The 'FromDhall' instance for 'Codec' uses the generic
    representation of @a@, together with the 'InterpretOptions' defined by @tag@ as
    a series of modifications to be applied on 'defaultInterpretOptions'.

    For the default behavior, using 'AsIs' (a synonym for @()@) as the @tag@
    leaves the interpret options alone, so it's equivalent to the empty instance
    we first tried to use.

    @'Field' a@ and @'Constructor' a@ can be used to modify, respectively, the
    'fieldModifier' and 'constructorModifier' options of 'InterpretOptions', by
    post-composing the modifier with @'textFunction' \@a@, that is, the value-level
    equivalent of @a@, obtained through the 'TextFunction' class.

    In the case of @Person@, we used

    @
      Codec (Field (CamelCase <<< DropPrefix "person")) Person
    @

    which means that the @Text -> Text@ version of

    @
      CamelCase <<< DropPrefix "person"
    @

    was used to modify the @fieldModifier@ option.

    In the value level, this translates to composing ('<<<')
    'Data.Text.Manipulate.toCamel' ('CamelCase') with @'dropPrefix' "person"@
    (@'DropPrefix' "person"@).

    Finally, @'SetSingletonConstructors' a@ can be used to set the
    'singletonConstructors' option of 'InterpretOptions', by replacing the option
    with the value-level equivalent of @a@.
    -}

    {- $setup
    >>> :set -XOverloadedStrings
    -}