module Mezzo.Compose.Templates
( pitchClassLits
, accidentalLits
, octaveLits
, mkDurLits
, mk32ndLits
, mkPitchLits
, mkKeyLits
, mkPitchSpecs
, scaleDegreeLits
, modeLits
, dyaTyLits
, triTyLits
, tetTyLits
, invLits
, mkDyaConvs
, mkTriConvs
, mkDoubledDConvs
, mkTetConvs
, mkDoubledTConvs
) where
import Mezzo.Model
import Mezzo.Compose.Types
import Mezzo.Compose.Builder
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (sequenceQ)
import Data.Char
import Control.Monad (join)
pitchClassLits :: DecsQ
pitchClassLits = genLitDecs pcFormatter "PC" ''PitchClass
accidentalLits :: DecsQ
accidentalLits = genLitDecs accFormatter "Acc" ''Accidental
octaveLits :: DecsQ
octaveLits = genLitDecs octFormatter "Oct" ''OctaveNum
scaleDegreeLits :: DecsQ
scaleDegreeLits = genLitDecs scaDegFormatter "ScaDeg" ''ScaleDegree
modeLits :: DecsQ
modeLits = genLitDecs modeFormatter "Mod" ''Mode
dyaTyLits :: DecsQ
dyaTyLits = genLitDecs choTyFormatter "DyaType" ''DyadType
triTyLits :: DecsQ
triTyLits = do
dcs <- filter (\n -> nameBase n /= "DoubledD") <$> getDataCons ''TriadType
join <$> traverse (mkSingLit choTyFormatter "TriType") dcs
tetTyLits :: DecsQ
tetTyLits = do
dcs <- filter (\n -> nameBase n /= "DoubledT") <$> getDataCons ''TetradType
join <$> traverse (mkSingLit choTyFormatter "TetType") dcs
invLits :: DecsQ
invLits = genLitDecs invFormatter "Inv" ''Inversion
mkSingLit :: Formatter -> String -> Name -> DecsQ
mkSingLit format sing dataName = do
tySig <- sigD valName $ appT pcTyCon ty
dec <- [d| $(valPat) = $(pcDataCon) |]
return $ tySig : dec
where
valName = mkName (format dataName)
valPat = varP valName
pcTyCon = conT $ mkName sing
ty = promotedT dataName
pcDataCon = conE $ mkName sing
mkPitchLits :: DecsQ
mkPitchLits = do
pcNames <- getDataCons ''PitchClass
accNames <- getDataCons ''Accidental
octNames <- getDataCons ''OctaveNum
let declareVal pc acc oct = do
let pcStr = pcFormatter pc
accStr = shortAccFormatter acc
octStr = shortOctFormatter oct
valName = mkName $ pcStr ++ accStr ++ octStr
tySig <- sigD valName $ [t| Pit (Pitch $(conT pc) $(conT acc) $(conT oct)) |]
dec <- [d| $(varP valName) = Pit |]
return $ tySig : dec
join <$> sequence (declareVal <$> pcNames <*> accNames <*> octNames)
mkDurLits :: Name -> DecsQ
mkDurLits name = do
let litName = mkName $ durLitFormatter name
litName' = mkName $ (durLitFormatter name ++ "\'")
literal <- do
tySig1 <- sigD litName $ [t| Dur $(conT name) |]
dec1 <- [d| $(varP litName) = Dur |]
tySig1' <- sigD litName' $ [t| Dur (Dot $(conT name)) |]
dec1' <- [d| $(varP litName') = Dur |]
return $ tySig1 : dec1 ++ tySig1' : dec1'
noteTerm <- do
let valName = mkName $ (durLitFormatter name) !! 1 : "n"
tySig2 <- sigD valName $ [t| forall r s. (ValidNote s r $(conT name), IntRep r) => RootT s r $(conT name) |]
dec2 <- [d| $(varP valName) = \p -> Note p $(varE litName) |]
let valName' = mkName $ (durLitFormatter name) !! 1 : "n\'"
tySig2' <- sigD valName' $ [t| forall r s. (ValidNote s r (Dot $(conT name)), IntRep r) => RootT s r (Dot $(conT name)) |]
dec2' <- [d| $(varP valName') = \p -> Note p $(varE litName') |]
return $ tySig2 : dec2 ++ tySig2' : dec2'
restTerm <- do
let valName = mkName $ (durLitFormatter name) !! 1 : "r"
tySig2 <- sigD valName $ [t| forall s. (ValidRest s $(conT name)) => RestT s $(conT name) |]
dec2 <- [d| $(varP valName) = const (Rest $(varE litName)) |]
let valName' = mkName $ (durLitFormatter name) !! 1 : "r\'"
tySig2' <- sigD valName' $ [t| forall s. (ValidRest s (Dot $(conT name))) => RestT s (Dot $(conT name)) |]
dec2' <- [d| $(varP valName') = const (Rest $(varE litName')) |]
return $ tySig2 : dec2 ++ tySig2' : dec2'
chordTerm <- do
let valName = mkName $ (durLitFormatter name) !! 1 : "c"
tySig2 <- sigD valName $ [t| forall n r s. (Primitive n, IntListRep r, ValidChord s r $(conT name)) => ChorT s (r :: ChordType n) $(conT name) |]
dec2 <- [d| $(varP valName) = \c -> Chord c $(varE litName) |]
let valName' = mkName $ (durLitFormatter name) !! 1 : "c\'"
tySig2' <- sigD valName' $ [t| forall n r s. (Primitive n, IntListRep r, ValidChord s r (Dot $(conT name))) => ChorT s (r :: ChordType n) (Dot $(conT name)) |]
dec2' <- [d| $(varP valName') = \c -> Chord c $(varE litName') |]
return $ tySig2 : dec2 ++ tySig2' : dec2'
return $ literal ++ noteTerm ++ restTerm ++ chordTerm
mk32ndLits :: DecsQ
mk32ndLits = do
let litName = mkName $ "_th"
literal <- do
tySig1 <- sigD litName $ [t| Dur $(conT ''ThirtySecond) |]
dec1 <- [d| $(varP litName) = Dur |]
return $ tySig1 : dec1
noteTerm <- do
let valName = mkName $ "tn"
tySig2 <- sigD valName $ [t| forall r s. (ValidNote s r $(conT ''ThirtySecond), IntRep r) => RootT s r $(conT ''ThirtySecond) |]
dec2 <- [d| $(varP valName) = \p -> Note p $(varE litName) |]
return $ tySig2 : dec2
restTerm <- do
let valName = mkName $ "tr"
tySig2 <- sigD valName $ [t| forall s. ValidRest s $(conT ''ThirtySecond) => RestT s $(conT ''ThirtySecond) |]
dec2 <- [d| $(varP valName) = const (Rest $(varE litName)) |]
return $ tySig2 : dec2
chordTerm <- do
let valName = mkName $ "tc"
tySig2 <- sigD valName $ [t| forall n r s. (Primitive n, IntListRep r, ValidChord s r $(conT ''ThirtySecond)) => ChorT s (r :: ChordType n) $(conT ''ThirtySecond) |]
dec2 <- [d| $(varP valName) = \c -> Chord c $(varE litName) |]
return $ tySig2 : dec2
return $ literal ++ noteTerm ++ restTerm ++ chordTerm
mkKeyLits :: DecsQ
mkKeyLits = do
pcNames <- getDataCons ''PitchClass
accNames <- getDataCons ''Accidental
modeNames <- getDataCons ''Mode
let declareVal pc acc mode = do
let pcStr = tail $ pcFormatter pc
accStr = shorterAccFormatter acc
modeStr = shortModeFormatter mode
valName = mkName $ pcStr ++ accStr ++ modeStr
tySig <- sigD valName $ [t| KeyS (Key $(conT pc) $(conT acc) $(conT mode)) |]
dec <- [d| $(varP valName) = KeyS |]
return $ tySig : dec
join <$> sequence (declareVal <$> pcNames <*> accNames <*> modeNames)
mkPitchSpecs :: DecsQ
mkPitchSpecs = do
pcNames <- getDataCons ''PitchClass
accNames <- getDataCons ''Accidental
octNames <- getDataCons ''OctaveNum
let declareVal pc acc oct = do
let pcStr = tail $ pcFormatter pc
accStr = shorterAccFormatter acc
octStr = shortOctFormatter oct
valName = mkName $ pcStr ++ accStr ++ octStr
tySig <- sigD valName $
[t| RootS (PitchRoot (Pitch $(conT pc) $(conT acc) $(conT oct) )) |]
dec <- [d| $(varP valName) = spec Root |]
return $ tySig : dec
join <$> sequence (declareVal <$> pcNames <*> accNames <*> octNames)
mkDyaConvs :: DecsQ
mkDyaConvs = do
triTyNames <- getDataCons ''DyadType
let declareFun choTy = do
let choStr = tail (choTyFormatter choTy)
valName1 = mkName $ choStr ++ "'"
valName2 = mkName $ choStr
tySig1 <- sigD valName1 $
[t| forall r i. ChorC' Dyad r $(conT choTy) i |]
dec1 <- [d| $(varP valName1) = \i -> constConv Cho |]
tySig2 <- sigD valName2 $
[t| forall r. ChorC Dyad r $(conT choTy) |]
dec2 <- [d| $(varP valName2) = constConv Cho |]
return $ (tySig1 : dec1) ++ (tySig2 : dec2)
join <$> traverse declareFun triTyNames
mkTriConvs :: DecsQ
mkTriConvs = do
triTyNames <- filter (\n -> nameBase n /= "DoubledD") <$> getDataCons ''TriadType
let declareFun choTy = do
let choStr = tail (choTyFormatter choTy)
valName1 = mkName $ choStr ++ "'"
valName2 = mkName $ choStr
tySig1 <- sigD valName1 $
[t| forall r i. ChorC' Triad r $(conT choTy) i |]
dec1 <- [d| $(varP valName1) = \i -> constConv Cho |]
tySig2 <- sigD valName2 $
[t| forall r. ChorC Triad r $(conT choTy) |]
dec2 <- [d| $(varP valName2) = constConv Cho |]
return $ (tySig1 : dec1) ++ (tySig2 : dec2)
join <$> traverse declareFun triTyNames
mkDoubledDConvs :: DecsQ
mkDoubledDConvs = do
triTyNames <- getDataCons ''DyadType
let declareFun choTy = do
let choStr = tail (choTyFormatter choTy)
valName1 = mkName $ choStr ++ "D'"
valName2 = mkName $ choStr ++ "D"
tySig1 <- sigD valName1 $
[t| forall r i. ChorC' Triad r (DoubledD $(conT choTy)) i |]
dec1 <- [d| $(varP valName1) = \i -> constConv Cho |]
tySig2 <- sigD valName2 $
[t| forall r. ChorC Triad r (DoubledD $(conT choTy)) |]
dec2 <- [d| $(varP valName2) = constConv Cho |]
return $ (tySig1 : dec1) ++ (tySig2 : dec2)
join <$> traverse declareFun triTyNames
mkTetConvs :: DecsQ
mkTetConvs = do
sevTyNames <- filter (\n -> nameBase n /= "DoubledT") <$> getDataCons ''TetradType
let declareFun choTy = do
let choStr = tail (choTyFormatter choTy)
valName1 = mkName $ choStr ++ "'"
valName2 = mkName $ choStr
tySig1 <- sigD valName1 $
[t| forall r i. ChorC' Tetrad r $(conT choTy) i |]
dec1 <- [d| $(varP valName1) = \i -> constConv Cho |]
tySig2 <- sigD valName2 $
[t| forall r. ChorC Tetrad r $(conT choTy) |]
dec2 <- [d| $(varP valName2) = constConv Cho |]
return $ (tySig1 : dec1) ++ (tySig2 : dec2)
join <$> traverse declareFun sevTyNames
mkDoubledTConvs :: DecsQ
mkDoubledTConvs = do
triTyNames <- filter (\n -> nameBase n /= "DoubledD") <$> getDataCons ''TriadType
let declareFun choTy = do
let choStr = tail (choTyFormatter choTy)
valName1 = mkName $ choStr ++ "D'"
valName2 = mkName $ choStr ++ "D"
tySig1 <- sigD valName1 $
[t| forall r i. ChorC' Tetrad r (DoubledT $(conT choTy)) i |]
dec1 <- [d| $(varP valName1) = \i -> constConv Cho |]
tySig2 <- sigD valName2 $
[t| forall r. ChorC Tetrad r (DoubledT $(conT choTy)) |]
dec2 <- [d| $(varP valName2) = constConv Cho |]
return $ (tySig1 : dec1) ++ (tySig2 : dec2)
join <$> traverse declareFun triTyNames
type Formatter = Name -> String
pcFormatter :: Formatter
pcFormatter pc = '_' : map toLower (nameBase pc)
accFormatter :: Formatter
accFormatter = ('_' :) . map toLower . take 2 . nameBase
octFormatter :: Formatter
octFormatter oct = "_o" ++ drop 3 (nameBase oct)
shortAccFormatter :: Formatter
shortAccFormatter (accFormatter -> "_fl") = "f"
shortAccFormatter (accFormatter -> name) = [name !! 1]
shorterAccFormatter :: Formatter
shorterAccFormatter (shortAccFormatter -> "n") = ""
shorterAccFormatter (shortAccFormatter -> name) = name
shortOctFormatter :: Formatter
shortOctFormatter name = case nameBase name of
"Oct_1" -> "_5"
"Oct0" -> "_4"
"Oct1" -> "_3"
"Oct2" -> "__"
"Oct3" -> "_"
"Oct4" -> ""
"Oct5" -> "'"
"Oct6" -> "''"
"Oct7" -> "'3"
"Oct8" -> "'4"
durLitFormatter :: Formatter
durLitFormatter = ('_' :) . map toLower . take 2 . nameBase
pitchLitFormatter :: Name -> Name -> Name -> String
pitchLitFormatter pc acc oct = pcFormatter pc ++ shortAccFormatter acc ++ shortOctFormatter oct
scaDegFormatter :: Formatter
scaDegFormatter name = "_" ++ map toLower (nameBase name)
modeFormatter :: Formatter
modeFormatter (nameBase -> name) = map toLower (take 3 name) ++ dropWhile isLower (tail name)
shortModeFormatter :: Formatter
shortModeFormatter (modeFormatter -> name) = '_' : take 3 name
choTyFormatter :: Formatter
choTyFormatter n = case nameBase n of
"MajThird" -> "_maj3"
"MinThird" -> "_min3"
"PerfFourth" -> "_fourth"
"PerfFifth" -> "_fifth"
"PerfOct" -> "_oct"
"MajTriad" -> "_maj"
"MinTriad" -> "_min"
"AugTriad" -> "_aug"
"DimTriad" -> "_dim"
"MajSeventh" -> "_maj7"
"MajMinSeventh" -> "_dom7"
"MinSeventh" -> "_min7"
"HalfDimSeventh" -> "_hdim7"
"DimSeventh" -> "_dim7"
invFormatter :: Formatter
invFormatter (nameBase -> name) = "i" ++ [last name]
getDataCons :: Name -> Q [Name]
getDataCons tyName = do
TyConI (DataD _ _ _ _ dcs _) <- reify tyName
return $ reverse $ map (\(NormalC pc _) -> pc) dcs
mapToDataCons :: (Name -> DecsQ) -> Name -> DecsQ
mapToDataCons f tyName = do
dcNames <- getDataCons tyName
join <$> traverse f dcNames
genLitDecs :: Formatter -> String -> Name -> DecsQ
genLitDecs format singName name = mapToDataCons (mkSingLit format singName) name