{-# LANGUAGE TemplateHaskell #-}

-- |
-- Copyright: © 2020 IOHK
-- License: Apache-2.0
--
-- This module contains Template-Haskell-specific extensions to the
-- [Bech32 library](https://github.com/input-output-hk/bech32).

module Codec.Binary.Bech32.TH
    (
      -- ** Quasi-Quotation Support
      humanReadablePart
    ) where

import Prelude

import Codec.Binary.Bech32
    ( HumanReadablePart, humanReadablePartFromText, humanReadablePartToText )
import Control.Exception
    ( throw )
import Data.Text
    ( Text )
import Language.Haskell.TH.Quote
    ( QuasiQuoter (..) )
import Language.Haskell.TH.Syntax
    ( Exp, Q )

import qualified Data.Text as T

-- | A quasiquoter for Bech32 human-readable prefixes.
--
-- This quasiquoter makes it possible to construct values of type
-- 'HumanReadablePart' at compile time, using string literals.
--
-- Failure to parse a string literal will result in a __compile-time error__.
--
-- See 'Codec.Binary.Bech32.HumanReadablePartError' for the set of possible
-- errors that can be raised.
--
-- Example:
--
-- >>> :set -XQuasiQuotes
-- >>> import Codec.Binary.Bech32
-- >>> import Codec.Binary.Bech32.TH
-- >>> let addrPrefix = [humanReadablePart|addr|]
-- >>> addrPrefix
-- HumanReadablePart "addr"
-- >>> :t addrPrefix
-- addrPrefix :: HumanReadablePart
--
humanReadablePart :: QuasiQuoter
humanReadablePart :: QuasiQuoter
humanReadablePart = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
quoteHumanReadablePart
    , quotePat :: String -> Q Pat
quotePat  = String -> String -> Q Pat
forall a. String -> a
notHandled String
"patterns"
    , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. String -> a
notHandled String
"types"
    , quoteDec :: String -> Q [Dec]
quoteDec  = String -> String -> Q [Dec]
forall a. String -> a
notHandled String
"declarations"
    }
  where
    notHandled :: String -> a
notHandled String
things =
      String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
things String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
          String
" are not handled by the Bech32 humanReadablePart quasiquoter."

quoteHumanReadablePart :: String -> Q Exp
quoteHumanReadablePart :: String -> Q Exp
quoteHumanReadablePart = String -> Q Exp
forall t. Lift t => t -> Q Exp
quote
    (String -> Q Exp) -> (String -> String) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
    (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HumanReadablePart -> Text
humanReadablePartToText
    (HumanReadablePart -> Text)
-> (String -> HumanReadablePart) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HumanReadablePart
unsafeHumanReadablePart
    (Text -> HumanReadablePart)
-> (String -> Text) -> String -> HumanReadablePart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
  where
    quote :: t -> Q Exp
quote t
t = [| unsafeHumanReadablePart t |]

unsafeHumanReadablePart :: Text -> HumanReadablePart
unsafeHumanReadablePart :: Text -> HumanReadablePart
unsafeHumanReadablePart = (HumanReadablePartError -> HumanReadablePart)
-> (HumanReadablePart -> HumanReadablePart)
-> Either HumanReadablePartError HumanReadablePart
-> HumanReadablePart
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HumanReadablePartError -> HumanReadablePart
forall a e. Exception e => e -> a
throw HumanReadablePart -> HumanReadablePart
forall a. a -> a
id (Either HumanReadablePartError HumanReadablePart
 -> HumanReadablePart)
-> (Text -> Either HumanReadablePartError HumanReadablePart)
-> Text
-> HumanReadablePart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either HumanReadablePartError HumanReadablePart
humanReadablePartFromText