-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{- | This is the part of "Derive.Scale.Theory" that's concerned with converting
    'Pitch.Pitch'es to and from 'Pitch.Note's.

    It's split off to avoid cluttering Theory, but also because the
    "Derive.Scale" import would make it a circular dependency.

    This is basically just a bunch of functions that take a million arguments
    to configure octave format, accidental format, key parsing, etc.  To
    avoid annoyingly long argument lists, they are mostly packaged up into
    records, such as 'Config', 'KeyConfig', and 'RelativeFormat'.

    It's basically all just an attempt to parameterize scale creation, so I
    can reuse the shared parts but still be able to configure them.  It winds
    up being complicated, probably due to how it's evolved in reaction to
    increasingly varied scales, rather than according to an overarching design.
-}
module Derive.Scale.TheoryFormat where
import qualified Data.Attoparsec.Text as A
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import           Data.Vector ((!))
import qualified Data.Vector.Unboxed as Unboxed

import qualified Util.Num as Num
import qualified Util.ParseText as ParseText
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Scale.Theory as Theory
import qualified Perform.Pitch as Pitch

import           Global


-- * types

-- | General purpose config.
data Config = Config {
    Config -> ShowOctave
config_show_octave :: ShowOctave
    , Config -> ParseOctave
config_parse_octave :: ParseOctave
    , Config -> AccidentalFormat
config_accidental :: AccidentalFormat
    }

default_config :: Config
default_config :: Config
default_config = Config
    { config_show_octave :: ShowOctave
config_show_octave = ShowOctave
show_octave
    , config_parse_octave :: ParseOctave
config_parse_octave = ParseOctave
parse_octave
    , config_accidental :: AccidentalFormat
config_accidental = AccidentalFormat
ascii_accidentals
    }

set_octave :: ShowOctave -> ParseOctave -> Config -> Config
set_octave :: ShowOctave -> ParseOctave -> Config -> Config
set_octave ShowOctave
show_octave ParseOctave
parse_octave Config
config = Config
config
    { config_show_octave :: ShowOctave
config_show_octave = ShowOctave
show_octave
    , config_parse_octave :: ParseOctave
config_parse_octave = ParseOctave
parse_octave
    }

type ShowOctave = Pitch.Octave -> Text -> Text
-- | This can't just be A.Parser Pitch.Octave because I don't know where the
-- octave is in the pitch text.
type ParseOctave = A.Parser (Pitch.PitchClass, Maybe Pitch.Accidentals)
    -> A.Parser RelativePitch

-- | Key config is only necessary for formatting that depends on the key, e.g.
-- 'RelativeFormat'.
data KeyConfig key = KeyConfig {
    forall key. KeyConfig key -> ParseKey key
key_parse :: ParseKey key
    -- | Default key if there is none, or it's not parseable.  Otherwise, a bad
    -- or missing key would mean you couldn't even display notes.
    , forall key. KeyConfig key -> key
key_default :: key
    }
type ParseKey key = Maybe Pitch.Key -> Either DeriveT.PitchError key

-- | This is a just-parsed pitch.  It hasn't yet been adjusted according to the
-- key, so it's not yet an absolute 'Pitch.Pitch'.  It also represents
-- a natural explicitly.
--
-- 'fmt_to_absolute' is responsible for converting this to a 'Pitch.Pitch',
-- likely via 'rel_to_absolute'.
data RelativePitch =
    RelativePitch !Pitch.Octave !Pitch.PitchClass !(Maybe Pitch.Accidentals)
    deriving (Accidentals -> RelativePitch -> ShowS
[RelativePitch] -> ShowS
RelativePitch -> String
(Accidentals -> RelativePitch -> ShowS)
-> (RelativePitch -> String)
-> ([RelativePitch] -> ShowS)
-> Show RelativePitch
forall a.
(Accidentals -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelativePitch] -> ShowS
$cshowList :: [RelativePitch] -> ShowS
show :: RelativePitch -> String
$cshow :: RelativePitch -> String
showsPrec :: Accidentals -> RelativePitch -> ShowS
$cshowsPrec :: Accidentals -> RelativePitch -> ShowS
Show)

instance Pretty RelativePitch where
    pretty :: RelativePitch -> Text
pretty (RelativePitch Accidentals
oct Accidentals
pc Maybe Accidentals
accs) = Text
"relative:"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Accidentals -> Text
forall a. Show a => a -> Text
showt Accidentals
oct Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Accidentals -> Text
forall a. Show a => a -> Text
showt Accidentals
pc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Accidentals -> Text
forall a. Pretty a => a -> Text
pretty Maybe Accidentals
accs

relative_to_absolute :: RelativePitch -> Pitch.Pitch
relative_to_absolute :: RelativePitch -> Pitch
relative_to_absolute (RelativePitch Accidentals
oct Accidentals
pc Maybe Accidentals
acc) =
    Accidentals -> Degree -> Pitch
Pitch.Pitch Accidentals
oct (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc (Accidentals -> Maybe Accidentals -> Accidentals
forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 Maybe Accidentals
acc))

-- * absolute

-- | Make an absolute scale starting at @a@.
letters :: Pitch.PitchClass -> Format
letters :: Accidentals -> Format
letters Accidentals
pc_per_octave =
    Text -> Degrees -> Format
make_absolute_format (Degrees -> Text
make_pattern Degrees
degrees) Degrees
degrees
    where degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees ([Text] -> Degrees) -> [Text] -> Degrees
forall a b. (a -> b) -> a -> b
$ Accidentals -> [Text] -> [Text]
forall a. Accidentals -> [a] -> [a]
take Accidentals
pc_per_octave [Text]
letter_degrees

letter_degrees :: [Text]
letter_degrees :: [Text]
letter_degrees = (Char -> Text) -> String -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
Text.singleton [Char
'a'..Char
'z']

-- | The usual 7 note scale, which wraps around at @c@ instead of @a@.
absolute_c :: Format
absolute_c :: Format
absolute_c = Text -> Degrees -> Format
make_absolute_format (Degrees -> Text
make_pattern Degrees
degrees) Degrees
degrees
    where degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees [Text]
absolute_c_degrees

absolute_c_degrees :: [Text]
absolute_c_degrees :: [Text]
absolute_c_degrees = [Text
"c", Text
"d", Text
"e", Text
"f", Text
"g", Text
"a", Text
"b"]

-- * relative

-- | Args for a relative scale format.
--
-- The 'Pitch.Pitch'es handled by a relative scale are still absolute, exactly
-- the same as the Pitches of an absolute scale.  The difference is that the
-- 'read_pitch' and 'show_pitch' functions adjust based on the key to display
-- the absolute Pitch relative to the tonic of the key.
data RelativeFormat key = RelativeFormat {
    forall key. RelativeFormat key -> Config
rel_config :: Config
    , forall key. RelativeFormat key -> KeyConfig key
rel_key_config :: KeyConfig key
    , forall key. RelativeFormat key -> ShowDegree key
rel_show_degree :: ShowDegree key
    , forall key. RelativeFormat key -> ToAbsolute key
rel_to_absolute :: ToAbsolute key
    }

-- | Given a relative pitch relative to the default key, adjust it to
-- be absolute.  This is so I can figure out if a relative pitch is valid
-- without knowing the key, as described in 'fmt_to_absolute'.
type ToAbsolute key = key -> Degrees -> RelativePitch -> Pitch.Pitch

-- | This is a specialization of 'ShowPitch' for show functions that need
-- a key.
type ShowDegree key = key -> ShowOctave -> Degrees -> AccidentalFormat
    -> Either Pitch.Degree Pitch.Pitch -> Pitch.Note

sargam :: RelativeFormat key -> Format
sargam :: forall key. RelativeFormat key -> Format
sargam = Text -> Degrees -> RelativeFormat key -> Format
forall key. Text -> Degrees -> RelativeFormat key -> Format
make_relative_format (Degrees -> Text
make_pattern Degrees
degrees) Degrees
degrees
    where degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees [Text
"s", Text
"r", Text
"g", Text
"m", Text
"p", Text
"d", Text
"n"]

cipher :: Pitch.PitchClass -> RelativeFormat key -> Format
cipher :: forall key. Accidentals -> RelativeFormat key -> Format
cipher Accidentals
pc_per_octave = Text -> Degrees -> RelativeFormat key -> Format
forall key. Text -> Degrees -> RelativeFormat key -> Format
make_relative_format Text
pattern Degrees
degrees
    where
    degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees [Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Accidentals -> Text
forall a. Show a => a -> Text
showt Accidentals
pc | Accidentals
pc <- [Accidentals
1..Accidentals
pc_per_octave]]
    pattern :: Text
pattern = Text
"-[1-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Accidentals -> Text
forall a. Show a => a -> Text
showt Accidentals
pc_per_octave Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

zh_cipher :: Pitch.PitchClass -> RelativeFormat key -> Format
zh_cipher :: forall key. Accidentals -> RelativeFormat key -> Format
zh_cipher Accidentals
pc_per_octave =
    Text -> Degrees -> RelativeFormat key -> Format
forall key. Text -> Degrees -> RelativeFormat key -> Format
make_relative_format (Degrees -> Text
make_pattern Degrees
degrees) Degrees
degrees
    where
    degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees ([Text] -> Degrees) -> [Text] -> Degrees
forall a b. (a -> b) -> a -> b
$ Accidentals -> [Text] -> [Text]
forall a. Accidentals -> [a] -> [a]
take Accidentals
pc_per_octave [Text]
ds
    ds :: [Text]
ds = [Text
"一", Text
"二", Text
"三", Text
"四", Text
"五", Text
"六", Text
"七", Text
"八", Text
"九", Text
"十"]

gongche :: RelativeFormat key -> Format
gongche :: forall key. RelativeFormat key -> Format
gongche = Text -> Degrees -> RelativeFormat key -> Format
forall key. Text -> Degrees -> RelativeFormat key -> Format
make_relative_format (Degrees -> Text
make_pattern Degrees
degrees) Degrees
degrees
    where degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees [Text
"士", Text
"下", Text
"ㄨ", Text
"工", Text
"六"]

make_pattern :: Degrees -> Text
make_pattern :: Degrees -> Text
make_pattern Degrees
degrees = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (Degrees -> [Text]
forall a. Vector a -> [a]
Vector.toList Degrees
degrees) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

-- * Format

-- | This is the central data structure for this module.  It has the set of
-- functions needed to parse and generate symbolic pitches.  Making one of
-- these gives you access to the set of functions in here, such as 'show_pitch'
-- and 'read_pitch', which in turn can be used to implement
-- a 'Derive.Scale.Scale'.
data Format = Format {
    Format -> ShowPitch
fmt_show :: ShowPitch
    -- | This doesn't need the key because that work is split off to
    -- 'fmt_to_absolute'.
    , Format -> Parser RelativePitch
fmt_read :: A.Parser RelativePitch
    -- | I need the key to parse the pitch, but that can't happen unless I want
    -- to give all pattern_lookup calls access to the env in scope.  But
    -- I don't need the env to recognize if it's a valid call or not.
    , Format -> Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute :: Maybe Pitch.Key -> RelativePitch
        -> Either DeriveT.PitchError Pitch.Pitch
    , Format -> Text
fmt_pattern :: !Text
    -- TODO why do I need this?  can I have keys with different octaves?
    -- It's used only by JustScales
    , Format -> Accidentals
fmt_pc_per_octave :: Pitch.PitchClass
    -- | True if this scale is relative to the key.
    , Format -> Bool
fmt_relative :: !Bool
    }

-- | This is used to show both a Pitch with an octave, and a Degree without
-- one (used for key names).  This is because the code is presumably mostly the
-- same.
type ShowPitch = Maybe Pitch.Key -> Either Pitch.Degree Pitch.Pitch
    -> Pitch.Note
type Degrees = Vector.Vector Text

make_degrees :: [Text] -> Degrees
make_degrees :: [Text] -> Degrees
make_degrees = [Text] -> Degrees
forall a. [a] -> Vector a
Vector.fromList

-- ** show keys

show_key :: Format -> Theory.Key -> Pitch.Key
show_key :: Format -> Key -> Key
show_key Format
fmt Key
key =
    Text -> Key
Pitch.Key (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ Text
tonic Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Text -> Bool
Text.null Text
name then Text
"" else Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)
    where
    tonic :: Text
tonic = Format -> Maybe Key -> Degree -> Text
show_degree Format
fmt Maybe Key
forall a. Maybe a
Nothing (Key -> Degree
Theory.key_tonic Key
key)
    name :: Text
name = Key -> Text
Theory.key_name Key
key

-- | Show a key along with its key signature.
show_key_signature :: Format -> Theory.Key -> Text
show_key_signature :: Format -> Key -> Text
show_key_signature Format
fmt Key
key =
    Key -> Text
Pitch.key_text (Format -> Key -> Key
show_key Format
fmt Key
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
intervals
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
commas (Format -> Key -> [Text]
show_signature Format
fmt Key
key)
    where
    intervals :: Text
intervals = [Text] -> Text
commas ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Accidentals -> Text) -> [Accidentals] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Accidentals -> Text
forall a. Show a => a -> Text
showt ([Accidentals] -> [Text]) -> [Accidentals] -> [Text]
forall a b. (a -> b) -> a -> b
$ Vector Accidentals -> [Accidentals]
forall a. Unbox a => Vector a -> [a]
Unboxed.toList (Vector Accidentals -> [Accidentals])
-> Vector Accidentals -> [Accidentals]
forall a b. (a -> b) -> a -> b
$ Key -> Vector Accidentals
Theory.key_intervals Key
key
    commas :: [Text] -> Text
commas = Text -> [Text] -> Text
Text.intercalate Text
", "

-- | Show the signature of the given key by showing each scale degree with the
-- the accidentals implied by the key signature.
show_signature :: Format -> Theory.Key -> [Text]
show_signature :: Format -> Key -> [Text]
show_signature Format
fmt Key
key =
    (Pitch -> Text) -> [Pitch] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Format -> Maybe Key -> Degree -> Text
show_degree Format
fmt Maybe Key
forall a. Maybe a
Nothing (Degree -> Text) -> (Pitch -> Degree) -> Pitch -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Degree
Pitch.pitch_degree) [Pitch]
pitches
    where
    pc_per_octave :: Accidentals
pc_per_octave = Vector Accidentals -> Accidentals
forall a. Unbox a => Vector a -> Accidentals
Unboxed.length (Key -> Vector Accidentals
Theory.key_intervals Key
key)
    pitches :: [Pitch]
pitches = (Accidentals -> Pitch) -> [Accidentals] -> [Pitch]
forall a b. (a -> b) -> [a] -> [b]
map Accidentals -> Pitch
transpose [Accidentals
0 .. Accidentals
pc_per_octave Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
- Accidentals
1]
    transpose :: Accidentals -> Pitch
transpose Accidentals
pc = Key -> Accidentals -> Pitch -> Pitch
Theory.transpose_diatonic Key
key Accidentals
pc
        (Accidentals -> Degree -> Pitch
Pitch.Pitch Accidentals
0 (Key -> Degree
Theory.key_tonic Key
key))

-- | Get the degree names of a chromatic scale in this key.
key_degrees :: Theory.Key -> Format -> [Text]
key_degrees :: Key -> Format -> [Text]
key_degrees Key
key Format
fmt = (Pitch -> Text) -> [Pitch] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Format -> Maybe Key -> Degree -> Text
show_degree Format
fmt Maybe Key
forall a. Maybe a
Nothing (Degree -> Text) -> (Pitch -> Degree) -> Pitch -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Degree
Pitch.pitch_degree) [Pitch]
pitches
    where
    per_octave :: Accidentals
per_octave = Layout -> Accidentals
Theory.layout_semis_per_octave (Key -> Layout
Theory.key_layout Key
key)
    pitches :: [Pitch]
pitches = (Accidentals -> Pitch) -> [Accidentals] -> [Pitch]
forall a b. (a -> b) -> [a] -> [b]
map Accidentals -> Pitch
transpose [Accidentals
0 .. Accidentals
per_octave Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
- Accidentals
1]
    transpose :: Accidentals -> Pitch
transpose Accidentals
steps = Key -> Accidentals -> Pitch -> Pitch
Theory.transpose_chromatic Key
key Accidentals
steps
        (Accidentals -> Degree -> Pitch
Pitch.Pitch Accidentals
0 (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
0 Accidentals
0))

-- ** show pitches

show_pitch :: Format -> Maybe Pitch.Key -> Pitch.Pitch -> Pitch.Note
show_pitch :: Format -> Maybe Key -> Pitch -> Note
show_pitch Format
fmt Maybe Key
key = Format -> ShowPitch
fmt_show Format
fmt Maybe Key
key (Either Degree Pitch -> Note)
-> (Pitch -> Either Degree Pitch) -> Pitch -> Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Either Degree Pitch
forall a b. b -> Either a b
Right

-- | 'show_pitch' adapted to 'Scale.scale_show'.
scale_show_pitch :: Format -> Maybe Pitch.Key -> Pitch.Pitch
    -> Either DeriveT.PitchError Pitch.Note
scale_show_pitch :: Format -> Maybe Key -> Pitch -> Either PitchError Note
scale_show_pitch Format
fmt Maybe Key
key = Note -> Either PitchError Note
forall a b. b -> Either a b
Right (Note -> Either PitchError Note)
-> (Pitch -> Note) -> Pitch -> Either PitchError Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> Maybe Key -> Pitch -> Note
show_pitch Format
fmt Maybe Key
key

show_degree :: Format -> Maybe Pitch.Key -> Pitch.Degree -> Text
show_degree :: Format -> Maybe Key -> Degree -> Text
show_degree Format
fmt Maybe Key
key = Note -> Text
Pitch.note_text (Note -> Text) -> (Degree -> Note) -> Degree -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> ShowPitch
fmt_show Format
fmt Maybe Key
key (Either Degree Pitch -> Note)
-> (Degree -> Either Degree Pitch) -> Degree -> Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Degree -> Either Degree Pitch
forall a b. a -> Either a b
Left

read_pitch :: Format -> Maybe Pitch.Key -> Pitch.Note
    -> Either DeriveT.PitchError Pitch.Pitch
read_pitch :: Format -> Maybe Key -> Note -> Either PitchError Pitch
read_pitch Format
fmt Maybe Key
key = Format -> Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute Format
fmt Maybe Key
key (RelativePitch -> Either PitchError Pitch)
-> (Note -> Either PitchError RelativePitch)
-> Note
-> Either PitchError Pitch
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Format -> Note -> Either PitchError RelativePitch
read_relative_pitch Format
fmt

-- | Parse a Note, but don't adjust it for the key.  This means that relative
-- pitches will likely be incorrect.  'ToAbsolute' documents why this needs
-- to be separate.
read_relative_pitch :: Format -> Pitch.Note
    -> Either DeriveT.PitchError RelativePitch
read_relative_pitch :: Format -> Note -> Either PitchError RelativePitch
read_relative_pitch Format
fmt Note
note = PitchError
-> Maybe RelativePitch -> Either PitchError RelativePitch
forall err a. err -> Maybe a -> Either err a
justErr (Note -> PitchError
DeriveT.UnparseableNote Note
note) (Maybe RelativePitch -> Either PitchError RelativePitch)
-> Maybe RelativePitch -> Either PitchError RelativePitch
forall a b. (a -> b) -> a -> b
$
    Parser RelativePitch -> Text -> Maybe RelativePitch
forall a. Parser a -> Text -> Maybe a
ParseText.maybe_parse (Format -> Parser RelativePitch
fmt_read Format
fmt) (Text -> Maybe RelativePitch) -> Text -> Maybe RelativePitch
forall a b. (a -> b) -> a -> b
$
    Note -> Text
Pitch.note_text Note
note

-- ** make

make_absolute_format :: Text -> Degrees -> Format
make_absolute_format :: Text -> Degrees -> Format
make_absolute_format = Config -> Text -> Degrees -> Format
make_absolute_format_config Config
default_config

make_absolute_format_keyed :: Config -> KeyConfig Theory.Key
    -> Text -> Degrees -> Format
make_absolute_format_keyed :: Config -> KeyConfig Key -> Text -> Degrees -> Format
make_absolute_format_keyed Config
config KeyConfig Key
key_config Text
pattern Degrees
degrees =
    (Config -> Text -> Degrees -> Format
make_absolute_format_config Config
config Text
pattern Degrees
degrees)
    { fmt_show :: ShowPitch
fmt_show = Config -> KeyConfig Key -> Degrees -> ShowPitch
show_pitch_keyed_absolute Config
config KeyConfig Key
key_config Degrees
degrees
    , fmt_read :: Parser RelativePitch
fmt_read = Config -> Degrees -> Parser RelativePitch
p_pitch Config
config Degrees
degrees
    , fmt_to_absolute :: Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute = \Maybe Key
maybe_key RelativePitch
pitch -> do
        Key
key <- KeyConfig Key -> ParseKey Key
forall key. KeyConfig key -> ParseKey key
key_parse KeyConfig Key
key_config Maybe Key
maybe_key
        Pitch -> Either PitchError Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch -> Either PitchError Pitch)
-> Pitch -> Either PitchError Pitch
forall a b. (a -> b) -> a -> b
$ Key -> RelativePitch -> Pitch
to_abs Key
key RelativePitch
pitch
    }
    where
    -- A note with no explicit accidentals gets the accidentals of the key
    -- signature.
    to_abs :: Key -> RelativePitch -> Pitch
to_abs Key
key (RelativePitch Accidentals
octave Accidentals
pc Maybe Accidentals
maybe_acc) = case Maybe Accidentals
maybe_acc of
        Maybe Accidentals
Nothing -> Accidentals -> Degree -> Pitch
Pitch.Pitch Accidentals
octave
            (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc (Key -> Accidentals -> Accidentals
Theory.accidentals_at_pc Key
key Accidentals
pc))
        Just Accidentals
acc -> Accidentals -> Degree -> Pitch
Pitch.Pitch Accidentals
octave (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc Accidentals
acc)

-- | A configurable version of 'make_absolute_format'.
make_absolute_format_config :: Config -> Text -> Degrees -> Format
make_absolute_format_config :: Config -> Text -> Degrees -> Format
make_absolute_format_config Config
config Text
pattern Degrees
degrees = Format
    { fmt_show :: ShowPitch
fmt_show = Config -> Degrees -> ShowPitch
show_pitch_absolute Config
config Degrees
degrees
    , fmt_read :: Parser RelativePitch
fmt_read = Config -> Degrees -> Parser RelativePitch
p_pitch Config
config Degrees
degrees
    , fmt_to_absolute :: Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute = \Maybe Key
_ -> Pitch -> Either PitchError Pitch
forall a b. b -> Either a b
Right (Pitch -> Either PitchError Pitch)
-> (RelativePitch -> Pitch)
-> RelativePitch
-> Either PitchError Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativePitch -> Pitch
relative_to_absolute
    , fmt_pattern :: Text
fmt_pattern = Text
octave_pattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_pattern
    , fmt_pc_per_octave :: Accidentals
fmt_pc_per_octave = Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
    , fmt_relative :: Bool
fmt_relative = Bool
False
    }

-- | Make a Format from a 'RelativeFormat'.
make_relative_format :: Text -> Degrees -> RelativeFormat key -> Format
make_relative_format :: forall key. Text -> Degrees -> RelativeFormat key -> Format
make_relative_format Text
pattern Degrees
degrees RelativeFormat key
rel_fmt = Format
    { fmt_show :: ShowPitch
fmt_show = ShowPitch
p_show
    , fmt_read :: Parser RelativePitch
fmt_read = Parser RelativePitch
p_read
    , fmt_to_absolute :: Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute = Maybe Key -> RelativePitch -> Either PitchError Pitch
p_absolute
    , fmt_pattern :: Text
fmt_pattern = Text
octave_pattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_pattern
    , fmt_pc_per_octave :: Accidentals
fmt_pc_per_octave = Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
    , fmt_relative :: Bool
fmt_relative = Bool
True
    }
    where
    RelativeFormat Config
config KeyConfig key
key_config ShowDegree key
show_degree ToAbsolute key
to_abs = RelativeFormat key
rel_fmt
    p_show :: ShowPitch
p_show Maybe Key
key = ShowDegree key
show_degree
        ((PitchError -> key) -> (key -> key) -> Either PitchError key -> key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (key -> PitchError -> key
forall a b. a -> b -> a
const (KeyConfig key -> key
forall key. KeyConfig key -> key
key_default KeyConfig key
key_config)) key -> key
forall a. a -> a
id (KeyConfig key -> ParseKey key
forall key. KeyConfig key -> ParseKey key
key_parse KeyConfig key
key_config Maybe Key
key))
        (Config -> ShowOctave
config_show_octave Config
config) Degrees
degrees (Config -> AccidentalFormat
config_accidental Config
config)
    p_read :: Parser RelativePitch
p_read = Config -> Degrees -> Parser RelativePitch
p_pitch Config
config Degrees
degrees
    p_absolute :: Maybe Key -> RelativePitch -> Either PitchError Pitch
p_absolute Maybe Key
maybe_key RelativePitch
pitch = do
        key
key <- KeyConfig key -> ParseKey key
forall key. KeyConfig key -> ParseKey key
key_parse KeyConfig key
key_config Maybe Key
maybe_key
        Pitch -> Either PitchError Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch -> Either PitchError Pitch)
-> Pitch -> Either PitchError Pitch
forall a b. (a -> b) -> a -> b
$ ToAbsolute key
to_abs key
key Degrees
degrees RelativePitch
pitch

acc_pattern :: Text
acc_pattern :: Text
acc_pattern = Text
"(bb|b|n|#|x)?"

octave_pattern :: Text
octave_pattern :: Text
octave_pattern = Text
"[-1-9]"

-- *** absolute

show_pitch_absolute :: Config -> Degrees -> ShowPitch
show_pitch_absolute :: Config -> Degrees -> ShowPitch
show_pitch_absolute Config
config Degrees
degrees Maybe Key
_key Either Degree Pitch
pitch =
    Text -> Note
Pitch.Note (Text -> Note) -> Text -> Note
forall a b. (a -> b) -> a -> b
$ case Either Degree Pitch
pitch of
        Left (Pitch.Degree Accidentals
pc Accidentals
acc) ->
            Degrees
degrees Degrees -> Accidentals -> Text
forall a. Vector a -> Accidentals -> a
! (Accidentals
pc Accidentals -> Accidentals -> Accidentals
forall a. Integral a => a -> a -> a
`mod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AccidentalFormat -> Accidentals -> Text
show_accidentals (Config -> AccidentalFormat
config_accidental Config
config) Accidentals
acc
        Right (Pitch.Pitch Accidentals
oct (Pitch.Degree Accidentals
pc_ Accidentals
acc)) ->
            Config -> ShowOctave
config_show_octave Config
config (Accidentals
oct Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                Degrees
degrees Degrees -> Accidentals -> Text
forall a. Vector a -> Accidentals -> a
! Accidentals
pc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AccidentalFormat -> Accidentals -> Text
show_accidentals (Config -> AccidentalFormat
config_accidental Config
config) Accidentals
acc
            where (Accidentals
pc_oct, Accidentals
pc) = Accidentals
pc_ Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees

-- *** relative

show_degree_chromatic :: ShowDegree Theory.Key
show_degree_chromatic :: ShowDegree Key
show_degree_chromatic Key
key ShowOctave
show_octave Degrees
degrees AccidentalFormat
acc_fmt Either Degree Pitch
degree_pitch =
    Text -> Note
Pitch.Note (Text -> Note) -> Text -> Note
forall a b. (a -> b) -> a -> b
$ case Either Degree Pitch
degree_pitch of
        Left Degree
_ -> Text
pc_text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_text
        Right (Pitch.Pitch Accidentals
oct Degree
_) ->
            ShowOctave
show_octave (Accidentals
oct Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) (Text
pc_text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_text)
    where
    Pitch.Degree Accidentals
pc Accidentals
acc = (Degree -> Degree)
-> (Pitch -> Degree) -> Either Degree Pitch -> Degree
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Degree -> Degree
forall a. a -> a
id Pitch -> Degree
Pitch.pitch_degree Either Degree Pitch
degree_pitch
    acc_text :: Text
acc_text = AccidentalFormat -> Accidentals -> Text
show_accidentals AccidentalFormat
acc_fmt (Accidentals -> Text) -> Accidentals -> Text
forall a b. (a -> b) -> a -> b
$ Accidentals
acc Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
- Key -> Accidentals -> Accidentals
Theory.accidentals_at_pc Key
key Accidentals
pc
    (Accidentals
pc_oct, Text
pc_text) =
        Degrees -> Accidentals -> Accidentals -> (Accidentals, Text)
show_pc Degrees
degrees (Degree -> Accidentals
Pitch.degree_pc (Key -> Degree
Theory.key_tonic Key
key)) Accidentals
pc

-- | Convert a relative pitch using the key signature key system defined by
-- 'Theory.Key'.
chromatic_to_absolute :: ToAbsolute Theory.Key
chromatic_to_absolute :: ToAbsolute Key
chromatic_to_absolute Key
key Degrees
degrees (RelativePitch Accidentals
octave Accidentals
pc Maybe Accidentals
maybe_acc) =
    Accidentals -> Degree -> Pitch
Pitch.Pitch (Accidentals
octave Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
oct) (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc2 Accidentals
acc2)
    where
    (Accidentals
oct, Accidentals
pc2) = (Accidentals
pc Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Degree -> Accidentals
Pitch.degree_pc Degree
tonic) Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
    acc2 :: Accidentals
acc2 = Accidentals -> Maybe Accidentals -> Accidentals
forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 Maybe Accidentals
maybe_acc Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ case Key -> Maybe (Vector Accidentals)
Theory.key_signature Key
key of
        -- If it's chromatic then I can't adjust for the mode, but I still
        -- want to map degree 1 to C# if I'm in C#.
        Maybe (Vector Accidentals)
Nothing -> Degree -> Accidentals
Pitch.degree_accidentals Degree
tonic
        Just Vector Accidentals
sig -> Accidentals -> Maybe Accidentals -> Accidentals
forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 (Vector Accidentals
sig Vector Accidentals -> Accidentals -> Maybe Accidentals
forall a. Unbox a => Vector a -> Accidentals -> Maybe a
Unboxed.!? Accidentals
pc) -- Should never get Nothing.
    tonic :: Degree
tonic = Key -> Degree
Theory.key_tonic Key
key

type Tonic = Pitch.PitchClass

show_degree_diatonic :: ShowDegree Tonic
show_degree_diatonic :: ShowDegree Accidentals
show_degree_diatonic Accidentals
tonic ShowOctave
show_octave Degrees
degrees AccidentalFormat
acc_fmt Either Degree Pitch
degree_pitch =
    Text -> Note
Pitch.Note (Text -> Note) -> Text -> Note
forall a b. (a -> b) -> a -> b
$ case Either Degree Pitch
degree_pitch of
        Left Degree
_ -> Text
pc_text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_text
        Right (Pitch.Pitch Accidentals
oct Degree
_) ->
            ShowOctave
show_octave (Accidentals
oct Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) (Text
pc_text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_text)
    where
    Pitch.Degree Accidentals
pc Accidentals
acc = (Degree -> Degree)
-> (Pitch -> Degree) -> Either Degree Pitch -> Degree
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Degree -> Degree
forall a. a -> a
id Pitch -> Degree
Pitch.pitch_degree Either Degree Pitch
degree_pitch
    acc_text :: Text
acc_text = AccidentalFormat -> Accidentals -> Text
show_accidentals AccidentalFormat
acc_fmt Accidentals
acc
    (Accidentals
pc_oct, Text
pc_text) = Degrees -> Accidentals -> Accidentals -> (Accidentals, Text)
show_pc Degrees
degrees Accidentals
tonic Accidentals
pc

show_pc :: Degrees -> Tonic -> Pitch.PitchClass -> (Pitch.Octave, Text)
show_pc :: Degrees -> Accidentals -> Accidentals -> (Accidentals, Text)
show_pc Degrees
degrees Accidentals
tonic Accidentals
pc = (Accidentals
oct, Degrees
degrees Degrees -> Accidentals -> Text
forall a. Vector a -> Accidentals -> a
! Accidentals
degree)
    where (Accidentals
oct, Accidentals
degree) = (Accidentals
pc Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
- Accidentals
tonic) Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees

-- | Convert a relative pitch using a simple diatonic key system, where the
-- key is just a note in the scale.
diatonic_to_absolute :: ToAbsolute Tonic
diatonic_to_absolute :: ToAbsolute Accidentals
diatonic_to_absolute Accidentals
tonic Degrees
degrees (RelativePitch Accidentals
octave Accidentals
pc Maybe Accidentals
maybe_acc) =
    Accidentals -> Degree -> Pitch
Pitch.Pitch (Accidentals
octave Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
oct) (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc2 (Accidentals -> Maybe Accidentals -> Accidentals
forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 Maybe Accidentals
maybe_acc))
    where (Accidentals
oct, Accidentals
pc2) = (Accidentals
pc Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
tonic) Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees

-- *** keyed relative

-- | Like 'show_degree_chromatic', but format the accidentals as staff notation
-- does, in that accidentals implicit in the key signature are omitted, and
-- a natural that differs from the key signature is emitted.
-- TODO tons of args, can I package some up?
show_pitch_keyed_absolute :: Config -> KeyConfig Theory.Key -> Degrees
    -> ShowPitch
show_pitch_keyed_absolute :: Config -> KeyConfig Key -> Degrees -> ShowPitch
show_pitch_keyed_absolute Config
config KeyConfig Key
key_config Degrees
degrees Maybe Key
maybe_key Either Degree Pitch
degree_pitch =
    Text -> Note
Pitch.Note (Text -> Note) -> Text -> Note
forall a b. (a -> b) -> a -> b
$ case Either Degree Pitch
degree_pitch of
        Left Degree
_ -> Text
pitch
        Right (Pitch.Pitch Accidentals
oct Degree
_) -> ShowOctave
show_octave (Accidentals
oct Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) Text
pitch
    where
    Pitch.Degree Accidentals
pc_ Accidentals
acc = (Degree -> Degree)
-> (Pitch -> Degree) -> Either Degree Pitch -> Degree
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Degree -> Degree
forall a. a -> a
id Pitch -> Degree
Pitch.pitch_degree Either Degree Pitch
degree_pitch
    (Accidentals
pc_oct, Accidentals
pc) = Accidentals
pc_ Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
    key :: Key
key = (PitchError -> Key) -> (Key -> Key) -> Either PitchError Key -> Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Key -> PitchError -> Key
forall a b. a -> b -> a
const (KeyConfig Key -> Key
forall key. KeyConfig key -> key
key_default KeyConfig Key
key_config)) Key -> Key
forall a. a -> a
id
        (KeyConfig Key -> ParseKey Key
forall key. KeyConfig key -> ParseKey key
key_parse KeyConfig Key
key_config Maybe Key
maybe_key)
    pitch :: Text
pitch = Degrees
degrees Degrees -> Accidentals -> Text
forall a. Vector a -> Accidentals -> a
! Accidentals
pc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_text
    acc_text :: Text
acc_text = AccidentalFormat -> Accidentals -> Accidentals -> Text
show_accidentals_keyed (Config -> AccidentalFormat
config_accidental Config
config)
        (Key -> Accidentals -> Accidentals
Theory.accidentals_at_pc Key
key Accidentals
pc) Accidentals
acc

-- * parse

p_pitch :: Config -> Degrees -> A.Parser RelativePitch
p_pitch :: Config -> Degrees -> Parser RelativePitch
p_pitch Config
config Degrees
degrees =
    Config -> ParseOctave
config_parse_octave Config
config
        ((,) (Accidentals
 -> Maybe Accidentals -> (Accidentals, Maybe Accidentals))
-> Parser Text Accidentals
-> Parser
     Text (Maybe Accidentals -> (Accidentals, Maybe Accidentals))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Accidentals
p_degree Parser Text (Maybe Accidentals -> (Accidentals, Maybe Accidentals))
-> Parser Text (Maybe Accidentals)
-> Parser Text (Accidentals, Maybe Accidentals)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AccidentalFormat -> Parser Text (Maybe Accidentals)
p_accidentals (Config -> AccidentalFormat
config_accidental Config
config))
    where
    p_degree :: Parser Text Accidentals
p_degree = [Parser Text Accidentals] -> Parser Text Accidentals
forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice
        [ Text -> Parser Text
A.string Text
text Parser Text -> Parser Text Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a. Monad m => a -> m a
return Accidentals
i
        | (Accidentals
i, Text
text) <- [Accidentals] -> [Text] -> [(Accidentals, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Accidentals
0..] (Degrees -> [Text]
forall a. Vector a -> [a]
Vector.toList Degrees
degrees)
        ]

-- ** octave

-- | Most scales display the octave as a leading number.
show_octave :: ShowOctave
show_octave :: ShowOctave
show_octave Accidentals
oct = (Accidentals -> Text
forall a. Show a => a -> Text
showt Accidentals
oct <>)

parse_octave :: ParseOctave
parse_octave :: ParseOctave
parse_octave Parser Text (Accidentals, Maybe Accidentals)
parse = do
    Accidentals
oct <- Parser Text Accidentals
ParseText.p_int
    (Accidentals
pc, Maybe Accidentals
acc) <- Parser Text (Accidentals, Maybe Accidentals)
parse
    RelativePitch -> Parser RelativePitch
forall (m :: * -> *) a. Monad m => a -> m a
return (RelativePitch -> Parser RelativePitch)
-> RelativePitch -> Parser RelativePitch
forall a b. (a -> b) -> a -> b
$ Accidentals -> Accidentals -> Maybe Accidentals -> RelativePitch
RelativePitch Accidentals
oct Accidentals
pc Maybe Accidentals
acc

-- ** accidentals

-- | natural, sharp1, sharp2, flat1, flat2
data AccidentalFormat = AccidentalFormat !Text !Text !Text !Text !Text
    deriving (Accidentals -> AccidentalFormat -> ShowS
[AccidentalFormat] -> ShowS
AccidentalFormat -> String
(Accidentals -> AccidentalFormat -> ShowS)
-> (AccidentalFormat -> String)
-> ([AccidentalFormat] -> ShowS)
-> Show AccidentalFormat
forall a.
(Accidentals -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AccidentalFormat] -> ShowS
$cshowList :: [AccidentalFormat] -> ShowS
show :: AccidentalFormat -> String
$cshow :: AccidentalFormat -> String
showsPrec :: Accidentals -> AccidentalFormat -> ShowS
$cshowsPrec :: Accidentals -> AccidentalFormat -> ShowS
Show)

ascii_accidentals :: AccidentalFormat
ascii_accidentals :: AccidentalFormat
ascii_accidentals = Text -> Text -> Text -> Text -> Text -> AccidentalFormat
AccidentalFormat Text
"n" Text
"#" Text
"x" Text
"b" Text
"bb"

symbol_accidentals :: AccidentalFormat
symbol_accidentals :: AccidentalFormat
symbol_accidentals = Text -> Text -> Text -> Text -> Text -> AccidentalFormat
AccidentalFormat Text
"`n`" Text
"`#`" Text
"`##`" Text
"`b`" Text
"`bb`"

p_accidentals :: AccidentalFormat -> A.Parser (Maybe Pitch.Accidentals)
p_accidentals :: AccidentalFormat -> Parser Text (Maybe Accidentals)
p_accidentals (AccidentalFormat Text
natural Text
sharp1 Text
sharp2 Text
flat1 Text
flat2) =
    Parser Text (Maybe Accidentals)
p_natural Parser Text (Maybe Accidentals)
-> Parser Text (Maybe Accidentals)
-> Parser Text (Maybe Accidentals)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Accidentals -> Maybe Accidentals
forall a. a -> Maybe a
Just (Accidentals -> Maybe Accidentals)
-> ([Accidentals] -> Accidentals)
-> [Accidentals]
-> Maybe Accidentals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Accidentals] -> Accidentals
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum ([Accidentals] -> Maybe Accidentals)
-> Parser Text [Accidentals] -> Parser Text (Maybe Accidentals)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Accidentals -> Parser Text [Accidentals]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 Parser Text Accidentals
p_acc Parser Text (Maybe Accidentals)
-> Parser Text (Maybe Accidentals)
-> Parser Text (Maybe Accidentals)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Accidentals -> Parser Text (Maybe Accidentals)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Accidentals
forall a. Maybe a
Nothing
    where
    p_natural :: Parser Text (Maybe Accidentals)
p_natural = Text -> Parser Text
A.string Text
natural Parser Text
-> Parser Text (Maybe Accidentals)
-> Parser Text (Maybe Accidentals)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe Accidentals -> Parser Text (Maybe Accidentals)
forall (m :: * -> *) a. Monad m => a -> m a
return (Accidentals -> Maybe Accidentals
forall a. a -> Maybe a
Just Accidentals
0)
    p_acc :: Parser Text Accidentals
p_acc = [Parser Text Accidentals] -> Parser Text Accidentals
forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice
        [ Text -> Parser Text
A.string Text
sharp1 Parser Text -> Parser Text Accidentals -> Parser Text Accidentals
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a. Monad m => a -> m a
return Accidentals
1
        , Text -> Parser Text
A.string Text
sharp2 Parser Text -> Parser Text Accidentals -> Parser Text Accidentals
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a. Monad m => a -> m a
return Accidentals
2
        , Text -> Parser Text
A.string Text
flat1 Parser Text -> Parser Text Accidentals -> Parser Text Accidentals
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a. Monad m => a -> m a
return (-Accidentals
1)
        , Text -> Parser Text
A.string Text
flat2 Parser Text -> Parser Text Accidentals -> Parser Text Accidentals
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a. Monad m => a -> m a
return (-Accidentals
2)
        ]

-- | Show accidentals relative to the key signature.
show_accidentals_keyed :: AccidentalFormat -> Pitch.Accidentals
    -> Pitch.Accidentals -> Text
show_accidentals_keyed :: AccidentalFormat -> Accidentals -> Accidentals -> Text
show_accidentals_keyed fmt :: AccidentalFormat
fmt@(AccidentalFormat Text
natural Text
_ Text
_ Text
_ Text
_) Accidentals
key_accs Accidentals
accs
    | Accidentals
accs Accidentals -> Accidentals -> Bool
forall a. Eq a => a -> a -> Bool
== Accidentals
key_accs = Text
""
    | Accidentals
accs Accidentals -> Accidentals -> Bool
forall a. Eq a => a -> a -> Bool
== Accidentals
0 Bool -> Bool -> Bool
&& Accidentals
key_accs Accidentals -> Accidentals -> Bool
forall a. Eq a => a -> a -> Bool
/= Accidentals
0 = Text
natural
    | Bool
otherwise = AccidentalFormat -> Accidentals -> Text
show_accidentals AccidentalFormat
fmt Accidentals
accs

show_accidentals :: AccidentalFormat -> Pitch.Accidentals -> Text
show_accidentals :: AccidentalFormat -> Accidentals -> Text
show_accidentals (AccidentalFormat Text
_ Text
sharp1 Text
sharp2 Text
flat1 Text
flat2) Accidentals
acc
    | Accidentals
acc Accidentals -> Accidentals -> Bool
forall a. Eq a => a -> a -> Bool
== Accidentals
0 = Text
""
    | Accidentals
acc Accidentals -> Accidentals -> Bool
forall a. Ord a => a -> a -> Bool
< Accidentals
0 = ShowOctave
Text.replicate Accidentals
x Text
flat2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ShowOctave
Text.replicate Accidentals
s Text
flat1
    | Bool
otherwise = ShowOctave
Text.replicate Accidentals
x Text
sharp2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ShowOctave
Text.replicate Accidentals
s Text
sharp1
    where (Accidentals
x, Accidentals
s) = Accidentals -> Accidentals
forall a. Num a => a -> a
abs Accidentals
acc Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Accidentals
2