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

{-# OPTIONS_HADDOCK not-home #-}

module Morley.Michelson.Typed.Scope.Internal.TH
  (module Morley.Michelson.Typed.Scope.Internal.TH
  ) where

import Debug qualified

import Language.Haskell.TH qualified as TH
import Morley.Michelson.Typed.Scope.Internal.ForbidT

byTPredicateSymCases :: TH.ExpQ -> [(TH.Name, TH.ExpQ)] -> TH.ExpQ -> TH.ExpQ
byTPredicateSymCases :: ExpQ -> [(Name, ExpQ)] -> ExpQ -> ExpQ
byTPredicateSymCases ExpQ
sp [(Name, ExpQ)]
specific ExpQ
rest = do
  TH.TyConI (TH.DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ [Con]
cons' [DerivClause]
_) <- Name -> Q Info
TH.reify ''SingTPredicateSym
  let cons :: [Name]
cons = [Con]
cons' [Con] -> (Con -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        TH.NormalC Name
nm [BangType]
_ -> Name
nm
        TH.GadtC [Name
nm] [BangType]
_ Kind
_ -> Name
nm
        Con
c -> Text -> Name
forall a. HasCallStack => Text -> a
error (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Text
"unexpected constructor " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Con -> Text
forall b a. (Show a, IsString b) => a -> b
Debug.show Con
c
      specCons :: [Name]
specCons = ((Name, ExpQ) -> Name) -> [(Name, ExpQ)] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Name, ExpQ) -> Name
forall a b. (a, b) -> a
fst [(Name, ExpQ)]
specific
      restCons :: [Name]
restCons = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Element [Name] -> [Name] -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
`notElem` [Name]
specCons) [Name]
cons
      cases :: [(Name, ExpQ)]
cases = [(Name, ExpQ)]
specific [(Name, ExpQ)] -> [(Name, ExpQ)] -> [(Name, ExpQ)]
forall a. Semigroup a => a -> a -> a
<> ([Name]
restCons [Name] -> (Name -> (Name, ExpQ)) -> [(Name, ExpQ)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (, ExpQ
rest))
      matches :: [(Q Pat, ExpQ)]
matches = (Name -> Q Pat) -> (Name, ExpQ) -> (Q Pat, ExpQ)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Name -> [Q Pat] -> Q Pat) -> [Q Pat] -> Name -> Q Pat
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
TH.conP []) ((Name, ExpQ) -> (Q Pat, ExpQ))
-> [(Name, ExpQ)] -> [(Q Pat, ExpQ)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, ExpQ)]
cases
  ExpQ -> [Q Match] -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
TH.caseE ExpQ
sp [ Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match Q Pat
pat (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB ExpQ
expr) [] | (Q Pat
pat, ExpQ
expr) <- [(Q Pat, ExpQ)]
matches ]