{-# OPTIONS_HADDOCK not-home #-}
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)
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)
)