TH.hs

-- 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 subs = do
  TyConI (DataD _ _ _ _ cons _) <- reify ''MichelinePrimitive
  forM cons \case
    NormalC nm _ -> subs nm $ mkName $ "C_" <> nameBase nm
    c -> error $ "unsupported " <> show (ppr c)

-- | Construct 'MichelinePrimitive' from its constructor name. NB: partial function!
primFromName :: Name -> MichelinePrimitive
primFromName 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)
  )