{-# LANGUAGE TemplateHaskellQuotes #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- |
-- Module      : Data.Pitch.TH
-- Copyright   : (c) Eric Bailey, 2025
--
-- License     : MIT
-- Maintainer  : eric@ericb.me
-- Stability   : experimental
-- Portability : POSIX
--
-- Template Haskell for creating pattern synonyms for 'Pitch'es.
module Data.Pitch.TH
  ( genPitchPatterns,
  )
where

import Control.Monad.Extra (concatForM)
import Data.Pitch (Pitch (..))
import Language.Haskell.TH
import Text.Printf (printf)

-- | Generate pattern synonyms from pitches of given pitch class for octaves @0@
-- through @10@.
genPitchPatterns :: Name -> Q [Dec]
genPitchPatterns :: Name -> Q [Dec]
genPitchPatterns Name
tyName =
  do
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ [Con]
constructors [DerivClause]
_) <- Name -> Q Info
reify Name
tyName
    [Int] -> (Int -> Q [Dec]) -> Q [Dec]
forall (m :: * -> *) a b. Monad m => [a] -> (a -> m [b]) -> m [b]
concatForM [Int]
octaves ((Int -> Q [Dec]) -> Q [Dec]) -> (Int -> Q [Dec]) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \Int
oct ->
      [Con] -> (Con -> Q [Dec]) -> Q [Dec]
forall (m :: * -> *) a b. Monad m => [a] -> (a -> m [b]) -> m [b]
concatForM [Con]
constructors ((Con -> Q [Dec]) -> Q [Dec]) -> (Con -> Q [Dec]) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \(NormalC Name
conName []) ->
        let strCon :: [Char]
strCon = Name -> [Char]
nameBase Name
conName
            strName :: [Char]
strName = [Char]
strCon [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
oct
            patName :: Name
patName = [Char] -> Name
mkName [Char]
strName
         in [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
              [ Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
patSynSigD Name
patName (Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Pitch) (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
tyName)),
                Name
-> Q PatSynArgs
-> Q PatSynDir
-> Q Pat
-> Maybe [Char]
-> [Maybe [Char]]
-> Q Dec
patSynD_doc
                  Name
patName
                  ([Name] -> Q PatSynArgs
forall (m :: * -> *). Quote m => [Name] -> m PatSynArgs
prefixPatSyn [])
                  Q PatSynDir
forall (m :: * -> *). Quote m => m PatSynDir
implBidir
                  ( Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP
                      'Pitch
                      [ [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP
                          [ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [],
                            Lit -> Q Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Integer -> Lit
integerL (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
oct))
                          ]
                      ]
                  )
                  ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> [Char] -> [Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"> %s = Pitch (%s, %d)" [Char]
strName [Char]
strCon Int
oct))
                  []
              ]

octaves :: [Int]
octaves :: [Int]
octaves = [Int
0 .. Int
10]