{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE OverloadedStrings  #-}

{-| This module contains logic for converting Dhall expressions to and from
    CBOR expressions which can in turn be converted to and from a binary
    representation
-}

module Dhall.Binary
    ( -- * Standard versions
      StandardVersion(..)
    , defaultStandardVersion
    , parseStandardVersion
    , renderStandardVersion

    -- * Encoding and decoding
    , ToTerm(..)
    , FromTerm(..)
    , encodeExpression
    , decodeExpression

    -- * Exceptions
    , DecodingFailure(..)
    ) where

import Codec.CBOR.Term (Term(..))
import Control.Applicative (empty, (<|>))
import Control.Exception (Exception)
import Dhall.Core
    ( Binding(..)
    , Chunks(..)
    , Const(..)
    , Directory(..)
    , Expr(..)
    , File(..)
    , FilePrefix(..)
    , Import(..)
    , ImportHashed(..)
    , ImportMode(..)
    , ImportType(..)
    , Scheme(..)
    , URL(..)
    , Var(..)
    )

import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Monoid ((<>))
import Data.Text (Text)
import Options.Applicative (Parser)
import Prelude hiding (exponent)
import GHC.Float (double2Float, float2Double)

import qualified Crypto.Hash
import qualified Data.ByteArray
import qualified Data.ByteString
import qualified Data.Sequence
import qualified Dhall.Map
import qualified Dhall.Set
import qualified Options.Applicative

-- | Supported version strings
data StandardVersion
    = NoVersion
    -- ^ No version string
    | V_5_0_0
    -- ^ Version "5.0.0"
    | V_4_0_0
    -- ^ Version "4.0.0"
    | V_3_0_0
    -- ^ Version "3.0.0"
    | V_2_0_0
    -- ^ Version "2.0.0"
    | V_1_0_0
    -- ^ Version "1.0.0"
    deriving (Enum, Bounded)

defaultStandardVersion :: StandardVersion
defaultStandardVersion = NoVersion

parseStandardVersion :: Parser StandardVersion
parseStandardVersion =
    Options.Applicative.option readVersion
        (   Options.Applicative.long "standard-version"
        <>  Options.Applicative.metavar "X.Y.Z"
        <>  Options.Applicative.help "The standard version to use"
        <>  Options.Applicative.value defaultStandardVersion
        )
  where
    readVersion = do
        string <- Options.Applicative.str
        case string :: Text of
            "none"  -> return NoVersion
            "1.0.0" -> return V_1_0_0
            "2.0.0" -> return V_2_0_0
            "3.0.0" -> return V_3_0_0
            "4.0.0" -> return V_4_0_0
            "5.0.0" -> return V_5_0_0
            _       -> fail "Unsupported version"

renderStandardVersion :: StandardVersion -> Text
renderStandardVersion NoVersion = "none"
renderStandardVersion V_1_0_0   = "1.0.0"
renderStandardVersion V_2_0_0   = "2.0.0"
renderStandardVersion V_3_0_0   = "3.0.0"
renderStandardVersion V_4_0_0   = "4.0.0"
renderStandardVersion V_5_0_0   = "5.0.0"

{-| Convert a function applied to multiple arguments to the base function and
    the list of arguments
-}
unApply :: Expr s a -> (Expr s a, [Expr s a])
unApply e₀ = (baseFunction₀, diffArguments₀ [])
  where
    ~(baseFunction₀, diffArguments₀) = go e₀

    go (App f a) = (baseFunction, diffArguments . (a :))
      where
        ~(baseFunction, diffArguments) = go f

    go (Note _ e) = go e

    go baseFunction = (baseFunction, id)

-- | Types that can be encoded as a CBOR `Term`
class ToTerm a where
    encode :: a -> Term

instance ToTerm a => ToTerm (Expr s a) where
    encode (Var (V "_" n)) =
        TInteger n
    encode (Var (V x n)) =
        TList [ TString x, TInteger n ]
    encode NaturalBuild =
        TString "Natural/build"
    encode NaturalFold =
        TString "Natural/fold"
    encode NaturalIsZero =
        TString "Natural/isZero"
    encode NaturalEven =
        TString "Natural/even"
    encode NaturalOdd =
        TString "Natural/odd"
    encode NaturalToInteger =
        TString "Natural/toInteger"
    encode NaturalShow =
        TString "Natural/show"
    encode IntegerToDouble =
        TString "Integer/toDouble"
    encode IntegerShow =
        TString "Integer/show"
    encode DoubleShow =
        TString "Double/show"
    encode ListBuild =
        TString "List/build"
    encode ListFold =
        TString "List/fold"
    encode ListLength =
        TString "List/length"
    encode ListHead =
        TString "List/head"
    encode ListLast =
        TString "List/last"
    encode ListIndexed =
        TString "List/indexed"
    encode ListReverse =
        TString "List/reverse"
    encode OptionalFold =
        TString "Optional/fold"
    encode OptionalBuild =
        TString "Optional/build"
    encode Bool =
        TString "Bool"
    encode Optional =
        TString "Optional"
    encode None =
        TString "None"
    encode Natural =
        TString "Natural"
    encode Integer =
        TString "Integer"
    encode Double =
        TString "Double"
    encode Text =
        TString "Text"
    encode TextShow =
        TString "Text/show"
    encode List =
        TString "List"
    encode (Const Type) =
        TString "Type"
    encode (Const Kind) =
        TString "Kind"
    encode (Const Sort) =
        TString "Sort"
    encode e@(App _ _) =
        TList ([ TInt 0, f₁ ] ++ map encode arguments)
      where
        (f₀, arguments) = unApply e

        f₁ = encode f₀
    encode (Lam "_" _A₀ b₀) =
        TList [ TInt 1, _A₁, b₁ ]
      where
        _A₁ = encode _A₀
        b₁  = encode b₀
    encode (Lam x _A₀ b₀) =
        TList [ TInt 1, TString x, _A₁, b₁ ]
      where
        _A₁ = encode _A₀
        b₁  = encode b₀
    encode (Pi "_" _A₀ _B₀) =
        TList [ TInt 2, _A₁, _B₁ ]
      where
        _A₁ = encode _A₀
        _B₁ = encode _B₀
    encode (Pi x _A₀ _B₀) =
        TList [ TInt 2, TString x, _A₁, _B₁ ]
      where
        _A₁ = encode _A₀
        _B₁ = encode _B₀
    encode (BoolOr l₀ r₀) =
        TList [ TInt 3, TInt 0, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (BoolAnd l₀ r₀) =
        TList [ TInt 3, TInt 1, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (BoolEQ l₀ r₀) =
        TList [ TInt 3, TInt 2, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (BoolNE l₀ r₀) =
        TList [ TInt 3, TInt 3, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (NaturalPlus l₀ r₀) =
        TList [ TInt 3, TInt 4, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (NaturalTimes l₀ r₀) =
        TList [ TInt 3, TInt 5, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (TextAppend l₀ r₀) =
        TList [ TInt 3, TInt 6, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (ListAppend l₀ r₀) =
        TList [ TInt 3, TInt 7, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (Combine l₀ r₀) =
        TList [ TInt 3, TInt 8, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (Prefer l₀ r₀) =
        TList [ TInt 3, TInt 9, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (CombineTypes l₀ r₀) =
        TList [ TInt 3, TInt 10, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (ImportAlt l₀ r₀) =
        TList [ TInt 3, TInt 11, l₁, r₁ ]
      where
        l₁ = encode l₀
        r₁ = encode r₀
    encode (ListLit _T₀ xs₀)
        | null xs₀  = TList [ TInt 4, _T₁ ]
        | otherwise = TList ([ TInt 4, TNull ] ++ xs₁)
      where
        _T₁ = case _T₀ of
            Nothing -> TNull
            Just t  -> encode t

        xs₁ = map encode (Data.Foldable.toList xs₀)
    encode (OptionalLit _T₀ Nothing) =
        TList [ TInt 5, _T₁ ]
      where
        _T₁ = encode _T₀
    encode (OptionalLit _T₀ (Just t₀)) =
        TList [ TInt 5, _T₁, t₁ ]
      where
        _T₁ = encode _T₀
        t₁  = encode t₀
    encode (Some t₀) =
        TList [ TInt 5, TNull, t₁ ]
      where
        t₁ = encode t₀
    encode (Merge t₀ u₀ Nothing) =
        TList [ TInt 6, t₁, u₁ ]
      where
        t₁ = encode t₀
        u₁ = encode u₀
    encode (Merge t₀ u₀ (Just _T₀)) =
        TList [ TInt 6, t₁, u₁, _T₁ ]
      where
        t₁  = encode t₀
        u₁  = encode u₀
        _T₁ = encode _T₀
    encode (Record xTs₀) =
        TList [ TInt 7, TMap xTs₁ ]
      where
        xTs₁ = do
            (x₀, _T₀) <- Dhall.Map.toList (Dhall.Map.sort xTs₀)
            let x₁  = TString x₀
            let _T₁ = encode _T₀
            return (x₁, _T₁)
    encode (RecordLit xts₀) =
        TList [ TInt 8, TMap xts₁ ]
      where
        xts₁ = do
            (x₀, t₀) <- Dhall.Map.toList (Dhall.Map.sort xts₀)
            let x₁ = TString x₀
            let t₁ = encode t₀
            return (x₁, t₁)
    encode (Field t₀ x) =
        TList [ TInt 9, t₁, TString x ]
      where
        t₁ = encode t₀
    encode (Project t₀ (Left xs₀)) =
        TList ([ TInt 10, t₁ ] ++ xs₁)
      where
        t₁  = encode t₀
        xs₁ = map TString (Dhall.Set.toList xs₀)
    encode (Project t₀ (Right _T₀)) =
        TList [ TInt 10, t₁, TList [ _T₁ ] ]
      where
        _T₁ = encode _T₀
        t₁  = encode t₀
    encode (Union xTs₀) =
        TList [ TInt 11, TMap xTs₁ ]
      where
        xTs₁ = do
            (x₀, mT₀) <- Dhall.Map.toList (Dhall.Map.sort xTs₀)

            let x₁  = TString x₀

            let _T₁ = case mT₀ of
                    Nothing  -> TNull
                    Just _T₀ -> encode _T₀

            return (x₁, _T₁)
    encode (UnionLit x t₀ yTs₀) =
        TList [ TInt 12, TString x, t₁, TMap yTs₁ ]
      where
        t₁ = encode t₀

        yTs₁ = do
            (y₀, mT₀) <- Dhall.Map.toList (Dhall.Map.sort yTs₀)
            let y₁  = TString y₀
            let _T₁ = case mT₀ of
                    Just _T₀ -> encode _T₀
                    Nothing  -> TNull
            return (y₁, _T₁)
    encode (BoolLit b) =
        TBool b
    encode (BoolIf t₀ l₀ r₀) =
        TList [ TInt 14, t₁, l₁, r₁ ]
      where
        t₁ = encode t₀
        l₁ = encode l₀
        r₁ = encode r₀
    encode (NaturalLit n) =
        TList [ TInt 15, TInteger (fromIntegral n) ]
    encode (IntegerLit n) =
        TList [ TInt 16, TInteger n ]
    encode (DoubleLit n64)
        -- cborg always encodes NaN as "7e00"
        | isNaN n64 = THalf n32
        | useHalf   = THalf n32
        | useFloat  = TFloat n32
        | otherwise = TDouble n64
      where
        n32      = double2Float n64
        useFloat = n64 == float2Double n32
        -- the other three cases for Half-floats are 0.0 and the infinities
        useHalf  = or $ fmap (n64 ==) [0.0, infinity, -infinity]
        infinity = 1/0 :: Double
    encode (TextLit (Chunks xys₀ z₀)) =
        TList ([ TInt 18 ] ++ xys₁ ++ [ z₁ ])
      where
        xys₁ = do
            (x₀, y₀) <- xys₀
            let x₁ = TString x₀
            let y₁ = encode y₀
            [ x₁, y₁ ]

        z₁ = TString z₀
    encode (Embed x) =
        encode x
    encode (Let as₀ b₀) =
        TList ([ TInt 25 ] ++ as₁ ++ [ b₁ ])
      where
        as₁ = do
            Binding x mA₀ a₀ <- toList as₀

            let mA₁ = case mA₀ of
                    Nothing  -> TNull
                    Just _A₀ -> encode _A₀

            let a₁ = encode a₀

            [ TString x, mA₁, a₁ ]

        b₁ = encode b₀
    encode (Annot t₀ _T₀) =
        TList [ TInt 26, t₁, _T₁ ]
      where
        t₁  = encode t₀
        _T₁ = encode _T₀
    encode (Note _ e) =
        encode e

instance ToTerm Import where
    encode import_ =
        case importType of
            Remote (URL { scheme = scheme₀, ..}) ->
                TList
                    (   prefix
                    ++  [ TInt scheme₁, using, TString authority ]
                    ++  map TString (reverse components)
                    ++  [ TString file ]
                    ++  (case query    of Nothing -> [ TNull ]; Just q -> [ TString q ])
                    )
              where
                using = case headers of
                    Nothing ->
                        TNull
                    Just h ->
                        encode h

                scheme₁ = case scheme₀ of
                    HTTP  -> 0
                    HTTPS -> 1
                File {..} = path

                Directory {..} = directory

            Local prefix₀ path ->
                    TList
                        (   prefix
                        ++  [ TInt prefix₁ ]
                        ++  map TString components₁
                        ++  [ TString file ]
                        )
              where
                File {..} = path

                Directory {..} = directory

                prefix₁ = case prefix₀ of
                  Absolute -> 2
                  Here     -> 3
                  Parent   -> 4
                  Home     -> 5

                components₁ = reverse components

            Env x ->
                TList (prefix ++ [ TInt 6, TString x ])

            Missing ->
                TList (prefix ++ [ TInt 7 ])
      where
        prefix = [ TInt 24, h, m ]
          where
            h = case hash of
                Nothing ->
                    TNull
                Just digest ->
                    TBytes ("\x12\x20" <> Data.ByteArray.convert digest)

            m = TInt (case importMode of Code -> 0; RawText -> 1)

        Import {..} = import_

        ImportHashed {..} = importHashed

-- | Types that can be decoded from a CBOR `Term`
class FromTerm a where
    decode :: Term -> Maybe a

instance FromTerm a => FromTerm (Expr s a) where
    decode (TInt n) =
        return (Var (V "_" (fromIntegral n)))
    decode (TInteger n) =
        return (Var (V "_" n))
    decode (TString "Natural/build") =
        return NaturalBuild
    decode (TString "Natural/fold") =
        return NaturalFold
    decode (TString "Natural/isZero") =
        return NaturalIsZero
    decode (TString "Natural/even") =
        return NaturalEven
    decode (TString "Natural/odd") =
        return NaturalOdd
    decode (TString "Natural/toInteger") =
        return NaturalToInteger
    decode (TString "Natural/show") =
        return NaturalShow
    decode (TString "Integer/toDouble") =
        return IntegerToDouble
    decode (TString "Integer/show") =
        return IntegerShow
    decode (TString "Double/show") =
        return DoubleShow
    decode (TString "List/build") =
        return ListBuild
    decode (TString "List/fold") =
        return ListFold
    decode (TString "List/length") =
        return ListLength
    decode (TString "List/head") =
        return ListHead
    decode (TString "List/last") =
        return ListLast
    decode (TString "List/indexed") =
        return ListIndexed
    decode (TString "List/reverse") =
        return ListReverse
    decode (TString "Optional/fold") =
        return OptionalFold
    decode (TString "Optional/build") =
        return OptionalBuild
    decode (TString "Bool") =
        return Bool
    decode (TString "Optional") =
        return Optional
    decode (TString "None") =
        return None
    decode (TString "Natural") =
        return Natural
    decode (TString "Integer") =
        return Integer
    decode (TString "Double") =
        return Double
    decode (TString "Text") =
        return Text
    decode (TString "Text/show") =
        return TextShow
    decode (TString "List") =
        return List
    decode (TString "Type") =
        return (Const Type)
    decode (TString "Kind") =
        return (Const Kind)
    decode (TString "Sort") =
        return (Const Sort)
    decode (TString "_") =
        empty
    decode (TList [ TString x, TInt n ]) =
        return (Var (V x (fromIntegral n)))
    decode (TList [ TString x, TInteger n ]) =
        return (Var (V x n))
    decode (TList (TInt 0 : f₁ : xs₁)) = do
        f₀  <- decode f₁
        xs₀ <- traverse decode xs₁
        return (foldl App f₀ xs₀)
    decode (TList [ TInt 1, _A₁, b₁ ]) = do
        _A₀ <- decode _A₁
        b₀  <- decode b₁
        return (Lam "_" _A₀ b₀)
    decode (TList [ TInt 1, TString x, _A₁, b₁ ]) = do
        _A₀ <- decode _A₁
        b₀  <- decode b₁
        return (Lam x _A₀ b₀)
    decode (TList [ TInt 2, _A₁, _B₁ ]) = do
        _A₀ <- decode _A₁
        _B₀ <- decode _B₁
        return (Pi "_" _A₀ _B₀)
    decode (TList [ TInt 2, TString x, _A₁, _B₁ ]) = do
        _A₀ <- decode _A₁
        _B₀ <- decode _B₁
        return (Pi x _A₀ _B₀)
    decode (TList [ TInt 3, TInt n, l₁, r₁ ]) = do
        l₀ <- decode l₁
        r₀ <- decode r₁
        op <- case n of
                0  -> return BoolOr
                1  -> return BoolAnd
                2  -> return BoolEQ
                3  -> return BoolNE
                4  -> return NaturalPlus
                5  -> return NaturalTimes
                6  -> return TextAppend
                7  -> return ListAppend
                8  -> return Combine
                9  -> return Prefer
                10 -> return CombineTypes
                11 -> return ImportAlt
                _  -> empty
        return (op l₀ r₀)
    decode (TList [ TInt 4, _T₁ ]) = do
        _T₀ <- decode _T₁
        return (ListLit (Just _T₀) empty)
    decode (TList (TInt 4 : TNull : xs₁ )) = do
        xs₀ <- traverse decode xs₁
        return (ListLit Nothing (Data.Sequence.fromList xs₀))
    decode (TList [ TInt 5, _T₁ ]) = do
        _T₀ <- decode _T₁
        return (OptionalLit _T₀ Nothing)
    decode (TList [ TInt 5, TNull, t₁ ]) = do
        t₀ <- decode t₁
        return (Some t₀)
    decode (TList [ TInt 5, _T₁, t₁ ]) = do
        _T₀ <- decode _T₁
        t₀  <- decode t₁
        return (OptionalLit _T₀ (Just t₀))
    decode (TList [ TInt 6, t₁, u₁ ]) = do
        t₀ <- decode t₁
        u₀ <- decode u₁
        return (Merge t₀ u₀ Nothing)
    decode (TList [ TInt 6, t₁, u₁, _T₁ ]) = do
        t₀  <- decode t₁
        u₀  <- decode u₁
        _T₀ <- decode _T₁
        return (Merge t₀ u₀ (Just _T₀))
    decode (TList [ TInt 7, TMap xTs₁ ]) = do
        let process (TString x, _T₁) = do
                _T₀ <- decode _T₁

                return (x, _T₀)
            process _ =
                empty

        xTs₀ <- traverse process xTs₁

        return (Record (Dhall.Map.fromList xTs₀))
    decode (TList [ TInt 8, TMap xts₁ ]) = do
        let process (TString x, t₁) = do
               t₀ <- decode t₁

               return (x, t₀)
            process _ =
                empty

        xts₀ <- traverse process xts₁

        return (RecordLit (Dhall.Map.fromList xts₀))
    decode (TList [ TInt 9, t₁, TString x ]) = do
        t₀ <- decode t₁

        return (Field t₀ x)
    decode (TList (TInt 10 : t₁ : xs₁)) = do
        t₀ <- decode t₁

        let expectString (TString x) = return x
            expectString  _          = empty

        let decodeLeft = do
                strings <- traverse expectString xs₁

                return (Left (Dhall.Set.fromList strings))

        let decodeRight =
                case xs₁ of
                    [ TList [ _T₁ ] ] -> do
                        _T₀ <- decode _T₁

                        return (Right _T₀)
                    _ -> do
                        empty

        xs₀ <- decodeLeft <|> decodeRight

        return (Project t₀ xs₀)
    decode (TList [ TInt 11, TMap xTs₁ ]) = do
        let process (TString x, _T₁) = do
                mT₀ <- case _T₁ of
                    TNull -> return Nothing
                    _     -> fmap Just (decode _T₁)

                return (x, mT₀)
            process _ =
                empty

        xTs₀ <- traverse process xTs₁

        return (Union (Dhall.Map.fromList xTs₀))
    decode (TList [ TInt 12, TString x, t₁, TMap yTs₁ ]) = do
        t₀ <- decode t₁

        let process (TString y, _T₁) = do
                _T₀ <- case _T₁ of
                    TNull -> return Nothing
                    _     -> fmap Just (decode _T₁)

                return (y, _T₀)
            process _ =
                empty

        yTs₀ <- traverse process yTs₁

        return (UnionLit x t₀ (Dhall.Map.fromList yTs₀))
    decode (TBool b) = do
        return (BoolLit b)
    decode (TList [ TInt 14, t₁, l₁, r₁ ]) = do
        t₀ <- decode t₁
        l₀ <- decode l₁
        r₀ <- decode r₁

        return (BoolIf t₀ l₀ r₀)
    decode (TList [ TInt 15, TInt n ]) = do
        return (NaturalLit (fromIntegral n))
    decode (TList [ TInt 15, TInteger n ]) = do
        return (NaturalLit (fromInteger n))
    decode (TList [ TInt 16, TInt n ]) = do
        return (IntegerLit (fromIntegral n))
    decode (TList [ TInt 16, TInteger n ]) = do
        return (IntegerLit n)
    decode (THalf n) = do
        return (DoubleLit (float2Double n))
    decode (TFloat n) = do
        return (DoubleLit (float2Double n))
    decode (TDouble n) = do
        return (DoubleLit n)
    decode (TList (TInt 18 : xs)) = do
        let process (TString x : y₁ : zs) = do
                y₀ <- decode y₁

                ~(xys, z) <- process zs

                return ((x, y₀) : xys, z)
            process [ TString z ] = do
                return ([], z)
            process _ = do
                empty

        (xys, z) <- process xs

        return (TextLit (Chunks xys z))
    decode e@(TList (TInt 24 : _)) = fmap Embed (decode e)
    decode (TList (TInt 25 : xs)) = do
        let process (TString x : _A₁ : a₁ : ls₁) = do
                mA₀ <- case _A₁ of
                    TNull -> return Nothing
                    _     -> fmap Just (decode _A₁)

                a₀  <- decode a₁

                let binding = Binding x mA₀ a₀

                case ls₁ of
                    [ b₁ ] -> do
                        b₀ <- decode b₁

                        return (Let (binding :| []) b₀)
                    _ -> do
                        Let (l₀ :| ls₀) b₀ <- process ls₁

                        return (Let (binding :| (l₀ : ls₀)) b₀)
            process _ = do
                empty

        process xs
    decode (TList [ TInt 26, t₁, _T₁ ]) = do
        t₀  <- decode t₁
        _T₀ <- decode _T₁
        return (Annot t₀ _T₀)
    decode _ =
        empty

instance FromTerm Import where
    decode (TList (TInt 24 : h : TInt mode : TInt n : xs)) = do
        hash <- case h of
            TNull -> do
                return Nothing

            TBytes bytes -> do
                let (prefix, suffix) = Data.ByteString.splitAt 2 bytes

                case prefix of
                    "\x12\x20" -> return ()
                    _          -> empty

                digest <- case Crypto.Hash.digestFromByteString suffix of
                    Nothing     -> empty
                    Just digest -> return digest

                return (Just digest)

            _ -> do
                empty

        importMode <- case mode of
            0 -> return Code
            1 -> return RawText
            _ -> empty

        let remote scheme = do
                let process [ TString file, q ] = do
                        query <- case q of
                            TNull     -> return Nothing
                            TString x -> return (Just x)
                            _         -> empty
                        return ([], file, query)
                    process (TString path : ys) = do
                        (paths, file, query) <- process ys
                        return (path : paths, file, query)
                    process _ = do
                        empty

                (headers, authority, paths, file, query) <- case xs of
                    headers₀ : TString authority : ys -> do
                        headers₁ <- case headers₀ of
                            TNull -> do
                                return Nothing
                            _     -> do
                                headers <- decode headers₀

                                return (Just headers)
                        (paths, file, query) <- process ys
                        return (headers₁, authority, paths, file, query)
                    _ -> do
                        empty

                let components = reverse paths
                let directory  = Directory {..}
                let path       = File {..}

                return (Remote (URL {..}))

        let local prefix = do
                let process [ TString file ] = do
                        return ([], file)
                    process (TString path : ys) = do
                        (paths, file) <- process ys
                        return (path : paths, file)
                    process _ =
                        empty

                (paths, file) <- process xs

                let components = reverse paths
                let directory  = Directory {..}

                return (Local prefix (File {..}))

        let env = do
                case xs of
                    [ TString x ] -> return (Env x)
                    _             -> empty

        let missing = return Missing

        importType <- case n of
            0 -> remote HTTP
            1 -> remote HTTPS
            2 -> local Absolute
            3 -> local Here
            4 -> local Parent
            5 -> local Home
            6 -> env
            7 -> missing
            _ -> empty

        let importHashed = ImportHashed {..}

        return (Import {..})

    decode _ = empty

strip55799Tag :: Term -> Term
strip55799Tag term =
    case term of
        TInt a ->
            TInt a
        TInteger a ->
            TInteger a
        TBytes a ->
            TBytes a
        TBytesI a ->
            TBytesI a
        TString a ->
            TString a
        TStringI a ->
            TStringI a
        TList as ->
            TList (fmap strip55799Tag as)
        TListI as ->
            TListI (fmap strip55799Tag as)
        TMap as ->
            TMap (fmap adapt as)
          where
            adapt (a, b) = (strip55799Tag a, strip55799Tag b)
        TMapI as ->
            TMapI (fmap adapt as)
          where
            adapt (a, b) = (strip55799Tag a, strip55799Tag b)
        TTagged 55799 b ->
            strip55799Tag b
        TTagged a b->
            TTagged a (strip55799Tag b)
        TBool a ->
            TBool a
        TNull ->
            TNull
        TSimple a ->
            TSimple a
        THalf a ->
            THalf a
        TFloat a ->
            TFloat a
        TDouble a ->
            TDouble a

-- | Encode a Dhall expression as a CBOR `Term`
encodeExpression :: Expr s Import -> Term
encodeExpression = encode

-- | Decode a Dhall expression from a CBOR `Term`
decodeExpression :: Term -> Either DecodingFailure (Expr s Import)
decodeExpression term =
    case decodeWithoutVersion <|> decodeWithVersion of
        Just expression -> Right expression
        Nothing         -> Left (CBORIsNotDhall term)
  where
    strippedTerm = strip55799Tag term
    -- This is the behavior specified by the standard
    decodeWithoutVersion = decode strippedTerm

    -- For backwards compatibility with older expressions that have a version
    -- tag to ease the migration
    decodeWithVersion = do
        TList [ TString _, taggedTerm ] <- return strippedTerm
        decode taggedTerm

data DecodingFailure = CBORIsNotDhall Term
    deriving (Eq)

instance Exception DecodingFailure

_ERROR :: String
_ERROR = "\ESC[1;31mError\ESC[0m"

instance Show DecodingFailure where
    show (CBORIsNotDhall term) =
            _ERROR <> ": Cannot decode CBOR to Dhall\n"
        <>  "\n"
        <>  "The following CBOR expression does not encode a valid Dhall expression\n"
        <>  "\n"
        <>  "↳ " <> show term <> "\n"