    {-# LANGUAGE CPP                 #-}
    {-# LANGUAGE OverloadedStrings   #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE ViewPatterns        #-}

    module Dhall.Import.Headers
        ( normalizeHeaders
        , originHeadersTypeExpr
        , toHeaders
        , toOriginHeaders
        ) where

    import Control.Applicative (Alternative (..), liftA2)
    import Control.Exception   (SomeException)
    import Control.Monad.Catch (handle, throwM)
    import Data.Text           (Text)
    import Data.Void           (Void)
    import Dhall.Core          (Chunks (..), Expr (..))
    import Dhall.Import.Types  (HTTPHeader, OriginHeaders)
    import Dhall.Parser        (Src (..))

    import qualified Data.CaseInsensitive
    import qualified Data.Foldable
    import qualified Data.HashMap.Strict   as HashMap
    import qualified Data.Text.Encoding
    import qualified Dhall.Core            as Core
    import qualified Dhall.Map
    import qualified Dhall.Pretty.Internal
    import qualified Dhall.TypeCheck

    -- | Given a well-typed (of type `List { header : Text, value Text }` or
    -- `List { mapKey : Text, mapValue Text }`) headers expressions in normal form
    -- construct the corresponding binary http headers; otherwise return the empty
    -- list.
    toHeaders :: Expr s a -> [HTTPHeader]
    toHeaders :: forall s a. Expr s a -> [HTTPHeader]
    toHeaders (ListLit Maybe (Expr s a)
    _ Seq (Expr s a)
    hs) = Seq HTTPHeader -> [HTTPHeader]
    forall a. Seq a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    Data.Foldable.toList (Maybe (Seq HTTPHeader) -> Seq HTTPHeader
    forall m. Monoid m => Maybe m -> m
    forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
    Data.Foldable.fold Maybe (Seq HTTPHeader)
    maybeHeaders)
      where
          maybeHeaders :: Maybe (Seq HTTPHeader)
    maybeHeaders = (Expr s a -> Maybe HTTPHeader)
    -> Seq (Expr s a) -> Maybe (Seq HTTPHeader)
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Seq a -> m (Seq b)
    mapM Expr s a -> Maybe HTTPHeader
    forall s a. Expr s a -> Maybe HTTPHeader
    toHeader Seq (Expr s a)
    hs
    toHeaders Expr s a
    _ = []

    toHeader :: Expr s a -> Maybe HTTPHeader
    toHeader :: forall s a. Expr s a -> Maybe HTTPHeader
    toHeader (RecordLit Map Text (RecordField s a)
    m) = do
        (Core.recordFieldValue -> TextLit (Chunks [] keyText), Core.recordFieldValue -> TextLit (Chunks [] valueText))
            <- Maybe (RecordField s a, RecordField s a)
    lookupHeader Maybe (RecordField s a, RecordField s a)
    -> Maybe (RecordField s a, RecordField s a)
    -> Maybe (RecordField s a, RecordField s a)
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Maybe (RecordField s a, RecordField s a)
    lookupMapKey
        let keyBytes   = Text -> ByteString
    Data.Text.Encoding.encodeUtf8 Text
    keyText
        let valueBytes = Text -> ByteString
    Data.Text.Encoding.encodeUtf8 Text
    valueText
        return (Data.CaseInsensitive.mk keyBytes, valueBytes)
          where
            lookupHeader :: Maybe (RecordField s a, RecordField s a)
    lookupHeader = (RecordField s a
     -> RecordField s a -> (RecordField s a, RecordField s a))
    -> Maybe (RecordField s a)
    -> Maybe (RecordField s a)
    -> Maybe (RecordField s a, RecordField s a)
    forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
    forall (f :: * -> *) a b c.
    Applicative f =>
    (a -> b -> c) -> f a -> f b -> f c
    liftA2 (,) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
    forall k v. Ord k => k -> Map k v -> Maybe v
    Dhall.Map.lookup Text
    "header" Map Text (RecordField s a)
    m) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
    forall k v. Ord k => k -> Map k v -> Maybe v
    Dhall.Map.lookup Text
    "value" Map Text (RecordField s a)
    m)
            lookupMapKey :: Maybe (RecordField s a, RecordField s a)
    lookupMapKey = (RecordField s a
     -> RecordField s a -> (RecordField s a, RecordField s a))
    -> Maybe (RecordField s a)
    -> Maybe (RecordField s a)
    -> Maybe (RecordField s a, RecordField s a)
    forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
    forall (f :: * -> *) a b c.
    Applicative f =>
    (a -> b -> c) -> f a -> f b -> f c
    liftA2 (,) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
    forall k v. Ord k => k -> Map k v -> Maybe v
    Dhall.Map.lookup Text
    "mapKey" Map Text (RecordField s a)
    m) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
    forall k v. Ord k => k -> Map k v -> Maybe v
    Dhall.Map.lookup Text
    "mapValue" Map Text (RecordField s a)
    m)
    toHeader Expr s a
    _ =
        Maybe HTTPHeader
    forall a. Maybe a
    forall (f :: * -> *) a. Alternative f => f a
    empty

    -- | Normalize, typecheck and return OriginHeaders from a given expression.
    toOriginHeaders :: Expr Src Void -> IO OriginHeaders
    toOriginHeaders :: Expr Src X -> IO OriginHeaders
    toOriginHeaders Expr Src X
    expr = (Expr Src X -> OriginHeaders)
    -> IO (Expr Src X) -> IO OriginHeaders
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Expr Src X -> OriginHeaders
    forall s a. Expr s a -> OriginHeaders
    convert (Expr Src X -> IO (Expr Src X)
    normalizeOriginHeaders Expr Src X
    expr)
      where
        convert :: Expr s a -> OriginHeaders
        convert :: forall s a. Expr s a -> OriginHeaders
    convert (ListLit Maybe (Expr s a)
    _ Seq (Expr s a)
    hs) = [(Text, [HTTPHeader])] -> OriginHeaders
    forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
    HashMap.fromList (Seq (Expr s a) -> [(Text, [HTTPHeader])]
    forall {t :: * -> *} {s} {a}.
    (Monoid (t (Text, [HTTPHeader])), Traversable t) =>
    t (Expr s a) -> [(Text, [HTTPHeader])]
    originPairs Seq (Expr s a)
    hs)
        convert Expr s a
    _ = OriginHeaders
    forall a. Monoid a => a
    mempty

        originPairs :: t (Expr s a) -> [(Text, [HTTPHeader])]
    originPairs t (Expr s a)
    hs = t (Text, [HTTPHeader]) -> [(Text, [HTTPHeader])]
    forall a. t a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    Data.Foldable.toList (Maybe (t (Text, [HTTPHeader])) -> t (Text, [HTTPHeader])
    forall m. Monoid m => Maybe m -> m
    forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
    Data.Foldable.fold ((Expr s a -> Maybe (Text, [HTTPHeader]))
    -> t (Expr s a) -> Maybe (t (Text, [HTTPHeader]))
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
    mapM Expr s a -> Maybe (Text, [HTTPHeader])
    forall s a. Expr s a -> Maybe (Text, [HTTPHeader])
    toOriginPair t (Expr s a)
    hs))

        toOriginPair :: Expr s a -> Maybe (Text, [HTTPHeader])
        toOriginPair :: forall s a. Expr s a -> Maybe (Text, [HTTPHeader])
    toOriginPair (RecordLit Map Text (RecordField s a)
    m) = do
          (Core.recordFieldValue -> TextLit (Chunks [] keyText), Core.recordFieldValue -> value)
              <- Maybe (RecordField s a, RecordField s a)
    lookupMapKey
          return (keyText, toHeaders value)
            where
              lookupMapKey :: Maybe (RecordField s a, RecordField s a)
    lookupMapKey = (RecordField s a
     -> RecordField s a -> (RecordField s a, RecordField s a))
    -> Maybe (RecordField s a)
    -> Maybe (RecordField s a)
    -> Maybe (RecordField s a, RecordField s a)
    forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
    forall (f :: * -> *) a b c.
    Applicative f =>
    (a -> b -> c) -> f a -> f b -> f c
    liftA2 (,) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
    forall k v. Ord k => k -> Map k v -> Maybe v
    Dhall.Map.lookup Text
    "mapKey" Map Text (RecordField s a)
    m) (Text -> Map Text (RecordField s a) -> Maybe (RecordField s a)
    forall k v. Ord k => k -> Map k v -> Maybe v
    Dhall.Map.lookup Text
    "mapValue" Map Text (RecordField s a)
    m)
        toOriginPair Expr s a
    _ = Maybe (Text, [HTTPHeader])
    forall a. Maybe a
    Nothing

    makeHeadersTypeExpr :: Text -> Text -> Expr Src Void
    makeHeadersTypeExpr :: Text -> Text -> Expr Src X
    makeHeadersTypeExpr Text
    keyKey Text
    valueKey =
      Expr Src X -> Expr Src X -> Expr Src X
    forall s a. Expr s a -> Expr s a -> Expr s a
    App Expr Src X
    forall s a. Expr s a
    List
          ( Map Text (RecordField Src X) -> Expr Src X
    forall s a. Map Text (RecordField s a) -> Expr s a
    Record (Map Text (RecordField Src X) -> Expr Src X)
    -> Map Text (RecordField Src X) -> Expr Src X
    forall a b. (a -> b) -> a -> b
    $ Expr Src X -> RecordField Src X
    forall s a. Expr s a -> RecordField s a
    Core.makeRecordField (Expr Src X -> RecordField Src X)
    -> Map Text (Expr Src X) -> Map Text (RecordField Src X)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$>
              [(Text, Expr Src X)] -> Map Text (Expr Src X)
    forall k v. Ord k => [(k, v)] -> Map k v
    Dhall.Map.fromList
                  [ (Text
    keyKey, Expr Src X
    forall s a. Expr s a
    Text)
                  , (Text
    valueKey, Expr Src X
    forall s a. Expr s a
    Text)
                  ]
          )

    headersTypeExpr :: Expr Src Void
    headersTypeExpr :: Expr Src X
    headersTypeExpr = Text -> Text -> Expr Src X
    makeHeadersTypeExpr Text
    "mapKey" Text
    "mapValue"

    leagacyHeadersTypeExpr :: Expr Src Void
    leagacyHeadersTypeExpr :: Expr Src X
    leagacyHeadersTypeExpr = Text -> Text -> Expr Src X
    makeHeadersTypeExpr Text
    "header" Text
    "value"

    originHeadersTypeExpr :: Expr Src Void
    originHeadersTypeExpr :: Expr Src X
    originHeadersTypeExpr =
      Expr Src X -> Expr Src X -> Expr Src X
    forall s a. Expr s a -> Expr s a -> Expr s a
    App Expr Src X
    forall s a. Expr s a
    List
          ( Map Text (RecordField Src X) -> Expr Src X
    forall s a. Map Text (RecordField s a) -> Expr s a
    Record (Map Text (RecordField Src X) -> Expr Src X)
    -> Map Text (RecordField Src X) -> Expr Src X
    forall a b. (a -> b) -> a -> b
    $ Expr Src X -> RecordField Src X
    forall s a. Expr s a -> RecordField s a
    Core.makeRecordField (Expr Src X -> RecordField Src X)
    -> Map Text (Expr Src X) -> Map Text (RecordField Src X)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$>
              [(Text, Expr Src X)] -> Map Text (Expr Src X)
    forall k v. Ord k => [(k, v)] -> Map k v
    Dhall.Map.fromList
                  [ (Text
    "mapKey", Expr Src X
    forall s a. Expr s a
    Text)
                  , (Text
    "mapValue", Expr Src X
    headersTypeExpr)
                  ]
          )

    typecheck :: Expr Src Void -> Expr Src Void -> IO (Expr Src Void)
    typecheck :: Expr Src X -> Expr Src X -> IO (Expr Src X)
    typecheck Expr Src X
    expected Expr Src X
    expr = do
        let suffix_ :: Text
    suffix_ = Expr Src X -> Text
    forall a. Pretty a => a -> Text
    Dhall.Pretty.Internal.prettyToStrictText Expr Src X
    expected
        let annot :: Expr Src X
    annot = case Expr Src X
    expr of
                Note (Src SourcePos
    begin SourcePos
    end Text
    bytes) Expr Src X
    _ ->
                    Src -> Expr Src X -> Expr Src X
    forall s a. s -> Expr s a -> Expr s a
    Note (SourcePos -> SourcePos -> Text -> Src
    Src SourcePos
    begin SourcePos
    end Text
    bytes') (Expr Src X -> Expr Src X -> Expr Src X
    forall s a. Expr s a -> Expr s a -> Expr s a
    Annot Expr Src X
    expr Expr Src X
    expected)
                  where
                    bytes' :: Text
    bytes' = Text
    bytes Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    " : " Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    suffix_
                Expr Src X
    _ ->
                    Expr Src X -> Expr Src X -> Expr Src X
    forall s a. Expr s a -> Expr s a -> Expr s a
    Annot Expr Src X
    expr Expr Src X
    expected

        _ <- case (Expr Src X -> Either (TypeError Src X) (Expr Src X)
    forall s. Expr s X -> Either (TypeError s X) (Expr s X)
    Dhall.TypeCheck.typeOf Expr Src X
    annot) of
            Left TypeError Src X
    err -> TypeError Src X -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    forall (m :: * -> *) e a.
    (MonadThrow m, HasCallStack, Exception e) =>
    e -> m a
    throwM TypeError Src X
    err
            Right Expr Src X
    _  -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

        return (Core.normalize expr)

    normalizeHeaders :: Expr Src Void -> IO (Expr Src Void)
    normalizeHeaders :: Expr Src X -> IO (Expr Src X)
    normalizeHeaders Expr Src X
    headersExpr = do
        let handler₀ :: SomeException -> IO (Expr Src X)
    handler₀ (SomeException
    e :: SomeException) = do
                {- Try to typecheck using the preferred @mapKey@/@mapValue@ fields
                   and fall back to @header@/@value@ if that fails. However, if
                   @header@/@value@ still fails then re-throw the original exception
                   for @mapKey@ / @mapValue@. -}
                let handler₁ :: SomeException -> m a
    handler₁ (SomeException
    _ :: SomeException) = SomeException -> m a
    forall e a. (HasCallStack, Exception e) => e -> m a
    forall (m :: * -> *) e a.
    (MonadThrow m, HasCallStack, Exception e) =>
    e -> m a
    throwM SomeException
    e
                (SomeException -> IO (Expr Src X))
    -> IO (Expr Src X) -> IO (Expr Src X)
    forall (m :: * -> *) e a.
    (HasCallStack, MonadCatch m, Exception e) =>
    (e -> m a) -> m a -> m a
    handle SomeException -> IO (Expr Src X)
    forall {m :: * -> *} {a}. MonadThrow m => SomeException -> m a
    handler₁ (Expr Src X -> Expr Src X -> IO (Expr Src X)
    typecheck Expr Src X
    leagacyHeadersTypeExpr Expr Src X
    headersExpr)

        (SomeException -> IO (Expr Src X))
    -> IO (Expr Src X) -> IO (Expr Src X)
    forall (m :: * -> *) e a.
    (HasCallStack, MonadCatch m, Exception e) =>
    (e -> m a) -> m a -> m a
    handle SomeException -> IO (Expr Src X)
    handler₀ (Expr Src X -> Expr Src X -> IO (Expr Src X)
    typecheck Expr Src X
    headersTypeExpr Expr Src X
    headersExpr)

    normalizeOriginHeaders :: Expr Src Void -> IO (Expr Src Void)
    normalizeOriginHeaders :: Expr Src X -> IO (Expr Src X)
    normalizeOriginHeaders = Expr Src X -> Expr Src X -> IO (Expr Src X)
    typecheck Expr Src X
    originHeadersTypeExpr