-- SPDX-FileCopyrightText: 2023 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_HADDOCK not-home #-}

-- | @TemplateHaskell@ helpers
module Morley.Micheline.Expression.Internal.TH
  ( module Morley.Micheline.Expression.Internal.TH
  ) where

import Prelude hiding (Type, lift)

import Language.Haskell.TH
  (Con(..), Dec(..), Info(..), Lit(..), Name, Q, mkName, nameBase, ppr, reify)
import Language.Haskell.TH.Lib (caseE, conE, litP, match, normalB)

import Morley.Micheline.Expression.Internal.MichelinePrimitive

withMichelinePrimitiveCons :: (Name -> Name -> Q r) -> Q [r]
withMichelinePrimitiveCons :: forall r. (Name -> Name -> Q r) -> Q [r]
withMichelinePrimitiveCons Name -> Name -> Q r
subs = do
  TyConI (DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ [Con]
cons [DerivClause]
_) <- Name -> Q Info
reify ''MichelinePrimitive
  [Con] -> (Con -> Q r) -> Q [r]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Con]
cons \case
    NormalC Name
nm [BangType]
_ -> Name -> Name -> Q r
subs Name
nm (Name -> Q r) -> Name -> Q r
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"C_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
nm
    Con
c -> Text -> Q r
forall a. HasCallStack => Text -> a
error (Text -> Q r) -> Text -> Q r
forall a b. (a -> b) -> a -> b
$ Text
"unsupported " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc -> Text
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show (Con -> Doc
forall a. Ppr a => a -> Doc
ppr Con
c)

-- | Construct 'MichelinePrimitive' from its constructor name. NB: partial function!
primFromName :: Name -> MichelinePrimitive
primFromName :: Name -> MichelinePrimitive
primFromName Name
inputName = $(do
  TyConI (DataD _ _ _ _ cons _) <- reify ''MichelinePrimitive
  caseE [|nameBase inputName|] $ cons <&> \case
    NormalC nm _ -> match (litP $ StringL $ nameBase nm) (normalB $ conE nm) []
    c -> error $ "unsupported " <> show (ppr c)
  )