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

{-# OPTIONS_HADDOCK not-home #-}

-- | A 'Enum' type that has constructors matching those of typed 'Instr'.
module Morley.Michelson.Typed.ClassifiedInstr.Internal.InstrEnum
  ( module Morley.Michelson.Typed.ClassifiedInstr.Internal.InstrEnum
  ) where

import Prelude hiding (Type)

import Language.Haskell.TH

import Morley.Michelson.Typed.Instr (Instr)

{-# ANN module ("HLint: ignore Language.Haskell.TH should be imported post-qualified or with an explicit import list" :: Text) #-}

-- | A enum type with the same constructors as 'Instr'. Used to specify
-- classifications a little more safely.
do
  TyConI (DataD _ _ _ _ cons _) <- reify ''Instr
  [DataD cxt' name tvb mk _ ders] <-
    [d|data InstrEnum deriving stock (Eq, Ord, Enum, Bounded, Show)|]
  let substOne :: Con -> Q Con
      substOne = \case
        GadtC [nm] _ _ -> normalC (mkName $ nameBase nm) []
        ForallC _ _ con -> substOne con
        c -> error $ "unsupported " <> show (ppr c)

  cons'' <- mapM substOne cons
  pure [DataD cxt' name tvb mk cons'' ders]

-- | Turn a 'Name' into its corresponding 'InstrEnum'. NB: partial function!
fromName :: Name -> InstrEnum
fromName (nameBase -> inputName) = $(do
  TyConI (DataD _ _ _ _ cons _) <- reify ''Instr
  let substOne :: Con -> Q Match
      substOne = \case
        GadtC [nm] _ _ ->
          match
            (litP $ StringL $ nameBase nm)
            (normalB $ conE (mkName $ nameBase nm)) []
        ForallC _ _ con -> substOne con
        c -> error $ "unsupported " <> show (ppr c)
  caseE [|inputName|] $ map substOne cons
  )