{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}

{-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining
    how to use the language, the compiler, and this library
-}

module Dhall.Marshal.Internal
    ( InputNormalizer(..)
    , defaultInputNormalizer
    , InterpretOptions(..)
    , SingletonConstructors(..)
    , defaultInterpretOptions

    -- * Miscellaneous
    , Result(..)

    -- * Helpers for the generic deriving machinery
    , getSelName
    , notEmptyRecord
    , notEmptyRecordLit
    , unsafeExpectRecord
    , unsafeExpectRecordLit
    , unsafeExpectUnion
    , unsafeExpectUnionLit

    -- * Re-exports
    , Fix(..)
    , HashMap
    , Int8
    , Int16
    , Int32
    , Int64
    , Map
    , Natural
    , Scientific
    , Seq
    , Text
    , Vector
    , Void
    , Word8
    , Word16
    , Word32
    , Word64
    , Generic
    ) where

import Control.Monad.Trans.State.Strict
import Data.Fix                         (Fix (..))
import Data.HashMap.Strict              (HashMap)
import Data.Int                         (Int16, Int32, Int64, Int8)
import Data.Map                         (Map)
import Data.Scientific                  (Scientific)
import Data.Sequence                    (Seq)
import Data.Text                        (Text)
import Data.Vector                      (Vector)
import Data.Void                        (Void)
import Data.Word                        (Word16, Word32, Word64, Word8)
import Dhall.Parser                     (Src (..))
import Dhall.Syntax                     (Expr (..), RecordField (..))
import GHC.Generics
import Numeric.Natural                  (Natural)
import Prelude                          hiding (maybe, sequence)

import qualified Data.Text
import qualified Dhall.Core as Core
import qualified Dhall.Map

{-| This type is exactly the same as `Data.Fix.Fix` except with a different
    `Dhall.Marshal.Decode.FromDhall` instance.  This intermediate type
    simplifies the implementation of the inner loop for the
    `Dhall.Marshal.Decode.FromDhall` instance for `Fix`.
-}
newtype Result f = Result { Result f -> f (Result f)
_unResult :: f (Result f) }

{-| Use these options to tweak how Dhall derives a generic implementation of
    `Dhall.Marshal.Decode.FromDhall`.
-}
data InterpretOptions = InterpretOptions
    { InterpretOptions -> Text -> Text
fieldModifier       :: Text -> Text
    -- ^ Function used to transform Haskell field names into their corresponding
    --   Dhall field names
    , InterpretOptions -> Text -> Text
constructorModifier :: Text -> Text
    -- ^ Function used to transform Haskell constructor names into their
    --   corresponding Dhall alternative names
    , InterpretOptions -> SingletonConstructors
singletonConstructors :: SingletonConstructors
    -- ^ Specify how to handle constructors with only one field.  The default is
    --   `Smart`
    }

{-| This is only used by the `Dhall.Marshal.Decode.FromDhall` instance for
    functions in order to normalize the function input before marshaling the
    input into a Dhall expression.
-}
newtype InputNormalizer = InputNormalizer
  { InputNormalizer -> ReifiedNormalizer Void
getInputNormalizer :: Core.ReifiedNormalizer Void }

-- | Default normalization-related settings (no custom normalization)
defaultInputNormalizer :: InputNormalizer
defaultInputNormalizer :: InputNormalizer
defaultInputNormalizer = InputNormalizer :: ReifiedNormalizer Void -> InputNormalizer
InputNormalizer
 { getInputNormalizer :: ReifiedNormalizer Void
getInputNormalizer = Normalizer Void -> ReifiedNormalizer Void
forall a. Normalizer a -> ReifiedNormalizer a
Core.ReifiedNormalizer (Identity (Maybe (Expr s Void))
-> Expr s Void -> Identity (Maybe (Expr s Void))
forall a b. a -> b -> a
const (Maybe (Expr s Void) -> Identity (Maybe (Expr s Void))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Expr s Void)
forall a. Maybe a
Nothing)) }

{-| This type specifies how to model a Haskell constructor with 1 field in
    Dhall

    For example, consider the following Haskell datatype definition:

    > data Example = Foo { x :: Double } | Bar Double

    Depending on which option you pick, the corresponding Dhall type could be:

    > < Foo : Double | Bar : Double >                   -- Bare

    > < Foo : { x : Double } | Bar : { _1 : Double } >  -- Wrapped

    > < Foo : { x : Double } | Bar : Double >           -- Smart
-}
data SingletonConstructors
    = Bare
    -- ^ Never wrap the field in a record
    | Wrapped
    -- ^ Always wrap the field in a record
    | Smart
    -- ^ Only fields in a record if they are named

{-| Default interpret options for generics-based instances,
    which you can tweak or override, like this:

> genericAutoWith
>     (defaultInterpretOptions { fieldModifier = Data.Text.Lazy.dropWhile (== '_') })
-}
defaultInterpretOptions :: InterpretOptions
defaultInterpretOptions :: InterpretOptions
defaultInterpretOptions = InterpretOptions :: (Text -> Text)
-> (Text -> Text) -> SingletonConstructors -> InterpretOptions
InterpretOptions
    { fieldModifier :: Text -> Text
fieldModifier =
          Text -> Text
forall a. a -> a
id
    , constructorModifier :: Text -> Text
constructorModifier =
          Text -> Text
forall a. a -> a
id
    , singletonConstructors :: SingletonConstructors
singletonConstructors =
          SingletonConstructors
Smart
    }

unsafeExpectUnion
    :: Text -> Expr Src Void -> Dhall.Map.Map Text (Maybe (Expr Src Void))
unsafeExpectUnion :: Text -> Expr Src Void -> Map Text (Maybe (Expr Src Void))
unsafeExpectUnion Text
_ (Union Map Text (Maybe (Expr Src Void))
kts) =
    Map Text (Maybe (Expr Src Void))
kts
unsafeExpectUnion Text
name Expr Src Void
expression =
    Text -> forall b. b
Core.internalError
        (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Unexpected constructor: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr Src Void -> Text
forall a. Pretty a => a -> Text
Core.pretty Expr Src Void
expression)

unsafeExpectRecord
    :: Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void)
unsafeExpectRecord :: Text -> Expr Src Void -> Map Text (RecordField Src Void)
unsafeExpectRecord Text
_ (Record Map Text (RecordField Src Void)
kts) =
    Map Text (RecordField Src Void)
kts
unsafeExpectRecord Text
name Expr Src Void
expression =
    Text -> forall b. b
Core.internalError
        (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Unexpected constructor: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr Src Void -> Text
forall a. Pretty a => a -> Text
Core.pretty Expr Src Void
expression)

unsafeExpectUnionLit
    :: Text
    -> Expr Src Void
    -> (Text, Maybe (Expr Src Void))
unsafeExpectUnionLit :: Text -> Expr Src Void -> (Text, Maybe (Expr Src Void))
unsafeExpectUnionLit Text
_ (Field (Union Map Text (Maybe (Expr Src Void))
_) (FieldSelection Src -> Text
forall s. FieldSelection s -> Text
Core.fieldSelectionLabel -> Text
k)) =
    (Text
k, Maybe (Expr Src Void)
forall a. Maybe a
Nothing)
unsafeExpectUnionLit Text
_ (App (Field (Union Map Text (Maybe (Expr Src Void))
_) (FieldSelection Src -> Text
forall s. FieldSelection s -> Text
Core.fieldSelectionLabel -> Text
k)) Expr Src Void
v) =
    (Text
k, Expr Src Void -> Maybe (Expr Src Void)
forall a. a -> Maybe a
Just Expr Src Void
v)
unsafeExpectUnionLit Text
name Expr Src Void
expression =
    Text -> forall b. b
Core.internalError
        (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Unexpected constructor: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr Src Void -> Text
forall a. Pretty a => a -> Text
Core.pretty Expr Src Void
expression)

unsafeExpectRecordLit
    :: Text -> Expr Src Void -> Dhall.Map.Map Text (RecordField Src Void)
unsafeExpectRecordLit :: Text -> Expr Src Void -> Map Text (RecordField Src Void)
unsafeExpectRecordLit Text
_ (RecordLit Map Text (RecordField Src Void)
kvs) =
    Map Text (RecordField Src Void)
kvs
unsafeExpectRecordLit Text
name Expr Src Void
expression =
    Text -> forall b. b
Core.internalError
        (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Unexpected constructor: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr Src Void -> Text
forall a. Pretty a => a -> Text
Core.pretty Expr Src Void
expression)

notEmptyRecordLit :: Expr s a -> Maybe (Expr s a)
notEmptyRecordLit :: Expr s a -> Maybe (Expr s a)
notEmptyRecordLit Expr s a
e = case Expr s a
e of
    RecordLit Map Text (RecordField s a)
m | Map Text (RecordField s a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text (RecordField s a)
m -> Maybe (Expr s a)
forall a. Maybe a
Nothing
    Expr s a
_                    -> Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
e

notEmptyRecord :: Expr s a -> Maybe (Expr s a)
notEmptyRecord :: Expr s a -> Maybe (Expr s a)
notEmptyRecord Expr s a
e = case Expr s a
e of
    Record Map Text (RecordField s a)
m | Map Text (RecordField s a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text (RecordField s a)
m -> Maybe (Expr s a)
forall a. Maybe a
Nothing
    Expr s a
_                 -> Expr s a -> Maybe (Expr s a)
forall a. a -> Maybe a
Just Expr s a
e

getSelName :: Selector s => M1 i s f a -> State Int Text
getSelName :: M1 i s f a -> State Int Text
getSelName M1 i s f a
n = case M1 i s f a -> [Char]
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName M1 i s f a
n of
    [Char]
"" -> do Int
i <- StateT Int Identity Int
forall (m :: * -> *) s. Monad m => StateT s m s
get
             Int -> StateT Int Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
             Text -> State Int Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Text
Data.Text.pack ([Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i))
    [Char]
nn -> Text -> State Int Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Text
Data.Text.pack [Char]
nn)