-- 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

-- | Utilities for simple scales, which simply map pitch names to frequencies.
-- Ok, so they also have octave structure, used by the input mechanism and to
-- parse to 'Pitch.Pitch'es, but it can be set to the number of degrees in the
-- scale if you don't have octaves.
module Derive.Scale.Scales where
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Vector as Vector
import           Data.Vector ((!?))

import qualified Util.Doc as Doc
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Texts as Texts

import qualified Derive.Call.ScaleDegree as ScaleDegree
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.PSignal as PSignal
import qualified Derive.Scale as Scale
import qualified Derive.Scale.Theory as Theory
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Pitch as Pitch

import           Global
import           Types


-- | Make a simple scale where there is a direct mapping from input to note to
-- nn.
make_scale :: Pitch.ScaleId -> DegreeMap -> Text -> Doc.Doc -> Scale.Scale
make_scale :: ScaleId -> DegreeMap -> Text -> Doc -> Scale
make_scale ScaleId
scale_id DegreeMap
dmap Text
pattern Doc
doc = Scale.Scale
    { scale_id :: ScaleId
scale_id = ScaleId
scale_id
    , scale_pattern :: Text
scale_pattern = Text
pattern
    , scale_symbols :: [Symbol]
scale_symbols = []
    , scale_transposers :: Set Control
scale_transposers = Set Control
standard_transposers
    , scale_read :: Environ -> Note -> Either PitchError Pitch
scale_read = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ DegreeMap -> Note -> Either PitchError Pitch
read_note DegreeMap
dmap
    , scale_show :: Environ -> Pitch -> Either PitchError Note
scale_show = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ DegreeMap -> Pitch -> Either PitchError Note
show_pitch DegreeMap
dmap
    , scale_bottom :: Pitch
scale_bottom = forall pc. Enum pc => PitchClass -> pc -> Pitch
Pitch.pitch (DegreeMap -> PitchClass
dm_start_octave DegreeMap
dmap) (DegreeMap -> PitchClass
dm_start_pc DegreeMap
dmap)
    , scale_layout :: Layout
scale_layout = PitchClass -> Layout
Scale.diatonic_layout (DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap)
    , scale_transpose :: Transpose
scale_transpose = DegreeMap -> Transpose
transpose DegreeMap
dmap
    , scale_enharmonics :: Enharmonics
scale_enharmonics = Enharmonics
no_enharmonics
    , scale_note_to_call :: Note -> Maybe ValCall
scale_note_to_call = DegreeMap -> Scale -> Note -> Maybe ValCall
mapped_note_to_call DegreeMap
dmap Scale
scale
    , scale_input_to_note :: Environ -> Input -> Either PitchError Note
scale_input_to_note = DegreeMap -> Environ -> Input -> Either PitchError Note
input_to_note DegreeMap
dmap
    , scale_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
scale_input_to_nn = DegreeMap
-> ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
mapped_input_to_nn DegreeMap
dmap
    , scale_call_doc :: DocumentedCall
scale_call_doc = Set Control -> DegreeMap -> Doc -> DocumentedCall
call_doc Set Control
standard_transposers DegreeMap
dmap Doc
doc
    }
    where scale :: Scale
scale = ScaleId -> Set Control -> Scale
PSignal.Scale ScaleId
scale_id Set Control
standard_transposers

-- | An empty scale that doesn't do anything.
empty_scale :: Pitch.ScaleId -> Text -> Derive.DocumentedCall -> Scale.Scale
empty_scale :: ScaleId -> Text -> DocumentedCall -> Scale
empty_scale ScaleId
scale_id Text
pattern DocumentedCall
doc = Scale.Scale
    { scale_id :: ScaleId
scale_id = ScaleId
scale_id
    , scale_pattern :: Text
scale_pattern = Text
pattern
    , scale_symbols :: [Symbol]
scale_symbols = []
    , scale_transposers :: Set Control
scale_transposers = Set Control
standard_transposers
    , scale_read :: Environ -> Note -> Either PitchError Pitch
scale_read = \Environ
_ Note
_ -> forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented
    , scale_show :: Environ -> Pitch -> Either PitchError Note
scale_show = \Environ
_ Pitch
_ -> forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented
    , scale_bottom :: Pitch
scale_bottom = forall pc. Enum pc => PitchClass -> pc -> Pitch
Pitch.pitch PitchClass
1 Integer
0
    , scale_layout :: Layout
scale_layout = [PitchClass] -> Layout
Scale.layout []
    , scale_transpose :: Transpose
scale_transpose = \Transposition
_ Environ
_ PitchClass
_ Pitch
_ -> forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented
    , scale_enharmonics :: Enharmonics
scale_enharmonics = Enharmonics
no_enharmonics
    , scale_note_to_call :: Note -> Maybe ValCall
scale_note_to_call = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
    , scale_input_to_note :: Environ -> Input -> Either PitchError Note
scale_input_to_note = \Environ
_ Input
_ -> forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented
    , scale_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
scale_input_to_nn = \ ScoreTime
_ Input
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented
    , scale_call_doc :: DocumentedCall
scale_call_doc = DocumentedCall
doc
    }

-- * types

-- TODO this is no longer used.  But still an example of a simple scale.
-- Move it some place like SimpleScales?
data DegreeMap = DegreeMap {
    DegreeMap -> Map Note PitchClass
dm_to_semis :: Map Pitch.Note Pitch.Semi
    , DegreeMap -> Vector Note
dm_to_note :: Vector.Vector Pitch.Note
    , DegreeMap -> Vector NoteNumber
dm_to_nn :: Vector.Vector Pitch.NoteNumber
    -- | Number of scale steps per octave.  Actually, simple scales are just
    -- a collection of frequencies and don't need to have a notion of an
    -- octave.  But since the input mechanism wants to orient around octaves,
    -- it needs to know how many keys to assign to each octave.  So if your
    -- scale has no octaves, then just set this to 7, that way it lines up with
    -- the piano keyboard.
    , DegreeMap -> PitchClass
dm_per_octave :: Pitch.Semi
    , DegreeMap -> PitchClass
dm_start_octave :: Pitch.Octave
    , DegreeMap -> PitchClass
dm_start_pc :: Pitch.PitchClass
    } deriving (PitchClass -> DegreeMap -> ShowS
[DegreeMap] -> ShowS
DegreeMap -> String
forall a.
(PitchClass -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DegreeMap] -> ShowS
$cshowList :: [DegreeMap] -> ShowS
show :: DegreeMap -> String
$cshow :: DegreeMap -> String
showsPrec :: PitchClass -> DegreeMap -> ShowS
$cshowsPrec :: PitchClass -> DegreeMap -> ShowS
Show)

instance Pretty DegreeMap where
    format :: DegreeMap -> Doc
format DegreeMap
dmap = forall a. Pretty a => a -> Doc
Pretty.format forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ do
        (Note
note, PitchClass
semis) <- forall k a. Map k a -> [(k, a)]
Map.toList (DegreeMap -> Map Note PitchClass
dm_to_semis DegreeMap
dmap)
        forall (m :: * -> *) a. Monad m => a -> m a
return (PitchClass
semis, (Note
note, DegreeMap -> Vector NoteNumber
dm_to_nn DegreeMap
dmap forall a. Vector a -> PitchClass -> Maybe a
!? PitchClass
semis))

degree_map :: Pitch.PitchClass
    -> Pitch.Octave -- ^ The first Note is this Octave and PitchClass.
    -> Pitch.PitchClass
    -> [Pitch.Note] -> [Pitch.NoteNumber] -> DegreeMap
degree_map :: PitchClass
-> PitchClass -> PitchClass -> [Note] -> [NoteNumber] -> DegreeMap
degree_map PitchClass
per_octave PitchClass
start_octave PitchClass
start_pc [Note]
notes_ [NoteNumber]
nns_ = DegreeMap
    { dm_to_semis :: Map Note PitchClass
dm_to_semis = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Note]
notes [PitchClass
0..])
    , dm_to_note :: Vector Note
dm_to_note = forall a. [a] -> Vector a
Vector.fromList [Note]
notes
    , dm_to_nn :: Vector NoteNumber
dm_to_nn = forall a. [a] -> Vector a
Vector.fromList [NoteNumber]
nns
    , dm_per_octave :: PitchClass
dm_per_octave = PitchClass
per_octave
    , dm_start_octave :: PitchClass
dm_start_octave = PitchClass
start_octave
    , dm_start_pc :: PitchClass
dm_start_pc = PitchClass
start_pc
    }
    where
    -- Guard against infinite notes or nns.
    ([Note]
notes, [NoteNumber]
nns) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Note]
notes_ [NoteNumber]
nns_

type SemisToNoteNumber = PSignal.PitchConfig -> Pitch.Semi
    -> Either DeriveT.PitchError Pitch.NoteNumber

-- * scale functions

read_note :: DegreeMap -> Pitch.Note -> Either DeriveT.PitchError Pitch.Pitch
read_note :: DegreeMap -> Note -> Either PitchError Pitch
read_note DegreeMap
dmap Note
note = DegreeMap -> PitchClass -> Pitch
semis_to_pitch DegreeMap
dmap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall err a. err -> Maybe a -> Either err a
justErr (Note -> PitchError
DeriveT.UnparseableNote Note
note) (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Note
note (DegreeMap -> Map Note PitchClass
dm_to_semis DegreeMap
dmap))

show_pitch :: DegreeMap -> Pitch.Pitch -> Either DeriveT.PitchError Pitch.Note
show_pitch :: DegreeMap -> Pitch -> Either PitchError Note
show_pitch DegreeMap
dmap Pitch
pitch = forall err a. err -> Maybe a -> Either err a
justErr
    (Text -> PitchError
DeriveT.PitchError (Text
"invalid pitch: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Pitch
pitch)) forall a b. (a -> b) -> a -> b
$
    DegreeMap -> Vector Note
dm_to_note DegreeMap
dmap forall a. Vector a -> PitchClass -> Maybe a
!? DegreeMap -> Pitch -> PitchClass
pitch_to_semis DegreeMap
dmap Pitch
pitch

-- ** transpose

transpose :: DegreeMap -> Derive.Transpose
transpose :: DegreeMap -> Transpose
transpose DegreeMap
dmap Transposition
_transposition Environ
_environ PitchClass
steps Pitch
pitch
    | forall a. Maybe a -> Bool
Maybe.isJust forall a b. (a -> b) -> a -> b
$ DegreeMap -> Vector Note
dm_to_note DegreeMap
dmap forall a. Vector a -> PitchClass -> Maybe a
!? PitchClass
transposed =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ DegreeMap -> PitchClass -> Pitch
semis_to_pitch DegreeMap
dmap PitchClass
transposed
    | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ OutOfRange -> PitchError
DeriveT.OutOfRangeError OutOfRange
DeriveT.out_of_range
    where transposed :: PitchClass
transposed = DegreeMap -> Pitch -> PitchClass
pitch_to_semis DegreeMap
dmap Pitch
pitch forall a. Num a => a -> a -> a
+ PitchClass
steps

-- | Transpose function for a non-transposing scale.
non_transposing :: Derive.Transpose
non_transposing :: Transpose
non_transposing Transposition
_ Environ
_ PitchClass
_ Pitch
_ = forall a b. a -> Either a b
Left PitchError
DeriveT.NotImplemented

-- | Indicate that this scale responds to the standard set of transpose
-- signals.  It still has to implement the support in its
-- 'Scale.scale_note_to_call'.
standard_transposers :: Set ScoreT.Control
standard_transposers :: Set Control
standard_transposers = forall a. Ord a => [a] -> Set a
Set.fromList
    [ Control
Controls.octave, Control
Controls.chromatic, Control
Controls.diatonic
    , Control
Controls.nn, Control
Controls.hz
    ]

-- ** note_to_call

-- | A specialization of 'note_to_call' that operates on scales with
-- a 'DegreeMap', i.e. a static map from notes to degrees, and from degrees to
-- NNs.
mapped_note_to_call :: DegreeMap -> PSignal.Scale
    -> Pitch.Note -> Maybe Derive.ValCall
mapped_note_to_call :: DegreeMap -> Scale -> Note -> Maybe ValCall
mapped_note_to_call DegreeMap
dmap Scale
scale Note
note = do
    PitchClass
semis <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Note
note (DegreeMap -> Map Note PitchClass
dm_to_semis DegreeMap
dmap)
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PitchClass
-> Maybe PitchClass
-> Scale
-> SemisToNoteNumber
-> (PitchClass -> Maybe Note)
-> ValCall
note_to_call (DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap) (forall a. a -> Maybe a
Just PitchClass
max_semi)
        Scale
scale (forall {p}.
PitchClass -> p -> PitchClass -> Either PitchError NoteNumber
semis_to_nn PitchClass
semis) (PitchClass -> PitchClass -> Maybe Note
semis_to_note PitchClass
semis)
    where
    max_semi :: PitchClass
max_semi = forall a. Vector a -> PitchClass
Vector.length (DegreeMap -> Vector NoteNumber
dm_to_nn DegreeMap
dmap)
    semis_to_nn :: PitchClass -> p -> PitchClass -> Either PitchError NoteNumber
semis_to_nn PitchClass
semis p
_config PitchClass
transpose =
        forall err a. err -> Maybe a -> Either err a
justErr PitchError
err forall a b. (a -> b) -> a -> b
$ DegreeMap -> Vector NoteNumber
dm_to_nn DegreeMap
dmap forall a. Vector a -> PitchClass -> Maybe a
!? (PitchClass
semis forall a. Num a => a -> a -> a
+ PitchClass
transpose)
        where
        err :: PitchError
err = forall a. Real a => a -> (PitchClass, PitchClass) -> PitchError
DeriveT.out_of_range_error (PitchClass
semis forall a. Num a => a -> a -> a
+ PitchClass
transpose) (PitchClass
0, PitchClass
max_semi)
    semis_to_note :: PitchClass -> PitchClass -> Maybe Note
semis_to_note PitchClass
semis PitchClass
transpose = DegreeMap -> Vector Note
dm_to_note DegreeMap
dmap forall a. Vector a -> PitchClass -> Maybe a
!? (PitchClass
semis forall a. Num a => a -> a -> a
+ PitchClass
transpose)

-- | Create a note call that respects chromatic and diatonic transposition.
-- However, diatonic transposition is mapped to chromatic transposition,
-- so this is for scales that don't distinguish.
note_to_call :: Pitch.Semi -> Maybe Pitch.Semi -> PSignal.Scale
    -> SemisToNoteNumber -> (Pitch.Semi -> Maybe Pitch.Note) -> Derive.ValCall
note_to_call :: PitchClass
-> Maybe PitchClass
-> Scale
-> SemisToNoteNumber
-> (PitchClass -> Maybe Note)
-> ValCall
note_to_call PitchClass
per_octave Maybe PitchClass
max_semi Scale
scale SemisToNoteNumber
semis_to_nn PitchClass -> Maybe Note
semis_to_note =
    Scale -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree Scale
scale PitchNn
pitch_nn PitchNote
pitch_note
    where
    pitch_nn :: Scale.PitchNn
    pitch_nn :: PitchNn
pitch_nn PitchConfig
config = PitchClass -> Frac -> PitchNn
to_nn PitchClass
transpose_steps Frac
frac PitchConfig
config
        where (PitchClass
transpose_steps, Frac
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction forall a b. (a -> b) -> a -> b
$ PitchConfig -> Frac
transposition PitchConfig
config
    to_nn :: PitchClass -> Frac -> PitchNn
to_nn PitchClass
semis Frac
frac PitchConfig
config
        | Frac
frac forall a. Eq a => a -> a -> Bool
== Frac
0 = SemisToNoteNumber
semis_to_nn PitchConfig
config PitchClass
semis
        | Bool
otherwise = forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SemisToNoteNumber
semis_to_nn PitchConfig
config PitchClass
semis
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SemisToNoteNumber
semis_to_nn PitchConfig
config (PitchClass
semis forall a. Num a => a -> a -> a
+ PitchClass
1)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Frac -> NoteNumber
Pitch.NoteNumber Frac
frac)
    pitch_note :: Scale.PitchNote
    pitch_note :: PitchNote
pitch_note PitchConfig
config = forall err a. err -> Maybe a -> Either err a
justErr PitchError
err forall a b. (a -> b) -> a -> b
$ PitchClass -> Maybe Note
semis_to_note PitchClass
semis
        where
        semis :: PitchClass
semis = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ PitchConfig -> Frac
transposition PitchConfig
config
        err :: PitchError
err = OutOfRange -> PitchError
DeriveT.OutOfRangeError forall a b. (a -> b) -> a -> b
$ OutOfRange
DeriveT.out_of_range
            { oor_degree :: Maybe Frac
DeriveT.oor_degree = forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchClass
semis)
            , oor_valid :: Maybe (PitchClass, PitchClass)
DeriveT.oor_valid = (PitchClass
0,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PitchClass
max_semi
            }
    transposition :: PitchConfig -> Frac
transposition PitchConfig
config =
        Control -> Frac
get Control
Controls.octave forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchClass
per_octave
            forall a. Num a => a -> a -> a
+ Control -> Frac
get Control
Controls.chromatic forall a. Num a => a -> a -> a
+ Control -> Frac
get Control
Controls.diatonic
        where get :: Control -> Frac
get Control
c = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Frac
0 Control
c (PitchConfig -> Map Control Frac
PSignal.pitch_controls PitchConfig
config)

add_pc :: DegreeMap -> Pitch.PitchClass -> Pitch.Pitch -> Pitch.Pitch
add_pc :: DegreeMap -> PitchClass -> Pitch -> Pitch
add_pc DegreeMap
dmap = PitchClass -> PitchClass -> Pitch -> Pitch
Pitch.add_pc (DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap)

-- ** input

type InputToNote = Env.Environ -> Pitch.Input
    -> Either DeriveT.PitchError Pitch.Note

-- | Input to note for simple scales without keys.
input_to_note :: DegreeMap -> InputToNote
input_to_note :: DegreeMap -> Environ -> Input -> Either PitchError Note
input_to_note DegreeMap
dmap Environ
_environ (Pitch.Input KbdType
kbd Pitch
pitch Frac
frac) = do
    PitchClass
steps <- DegreeMap -> KbdType -> Pitch -> Either PitchError PitchClass
simple_kbd_to_scale DegreeMap
dmap KbdType
kbd Pitch
pitch
    Note
note <- forall err a. err -> Maybe a -> Either err a
justErr PitchError
DeriveT.InvalidInput forall a b. (a -> b) -> a -> b
$ DegreeMap -> Vector Note
dm_to_note DegreeMap
dmap forall a. Vector a -> PitchClass -> Maybe a
!? PitchClass
steps
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Frac -> Note -> Note
ScaleDegree.pitch_expr Frac
frac Note
note

type InputToNn = ScoreTime -> Pitch.Input
    -> Derive.Deriver (Either DeriveT.PitchError Pitch.NoteNumber)

-- | Input to NoteNumber for scales that have a direct relationship between
-- Degree and NoteNumber.
mapped_input_to_nn :: DegreeMap -> InputToNn
mapped_input_to_nn :: DegreeMap
-> ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
mapped_input_to_nn DegreeMap
dmap = \ScoreTime
_pos (Pitch.Input KbdType
kbd Pitch
pitch Frac
frac) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
    PitchClass
semis <- DegreeMap -> KbdType -> Pitch -> Either PitchError PitchClass
simple_kbd_to_scale DegreeMap
dmap KbdType
kbd Pitch
pitch
    forall err a. err -> Maybe a -> Either err a
justErr (OutOfRange -> PitchError
DeriveT.OutOfRangeError OutOfRange
DeriveT.out_of_range) forall a b. (a -> b) -> a -> b
$
        PitchClass -> Frac -> Maybe NoteNumber
to_nn PitchClass
semis Frac
frac
    where
    to_nn :: PitchClass -> Frac -> Maybe NoteNumber
to_nn PitchClass
semis Frac
frac
        | Frac
frac forall a. Eq a => a -> a -> Bool
== Frac
0 = PitchClass -> Maybe NoteNumber
lookup PitchClass
semis
        | Frac
frac forall a. Ord a => a -> a -> Bool
> Frac
0 = do
            NoteNumber
nn <- PitchClass -> Maybe NoteNumber
lookup PitchClass
semis
            NoteNumber
next <- PitchClass -> Maybe NoteNumber
lookup (PitchClass
semis forall a. Num a => a -> a -> a
+ PitchClass
1)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
nn NoteNumber
next (Frac -> NoteNumber
Pitch.NoteNumber Frac
frac)
        | Bool
otherwise = do
            NoteNumber
nn <- PitchClass -> Maybe NoteNumber
lookup PitchClass
semis
            NoteNumber
prev <- PitchClass -> Maybe NoteNumber
lookup (PitchClass
semis forall a. Num a => a -> a -> a
- PitchClass
1)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
prev NoteNumber
nn (Frac -> NoteNumber
Pitch.NoteNumber (Frac
frac forall a. Num a => a -> a -> a
+ Frac
1))
    lookup :: PitchClass -> Maybe NoteNumber
lookup PitchClass
semis = DegreeMap -> Vector NoteNumber
dm_to_nn DegreeMap
dmap forall a. Vector a -> PitchClass -> Maybe a
!? PitchClass
semis

set_direct_input_to_nn :: Scale.Scale -> Scale.Scale
set_direct_input_to_nn :: Scale -> Scale
set_direct_input_to_nn Scale
scale = Scale
scale
    { scale_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
Scale.scale_input_to_nn = ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
direct_input_to_nn }

-- | An Input maps directly to a NoteNumber.  This is an efficient
-- implementation for scales tuned to 12TET.
--
-- This obeys 'Controls.octave' but none of the other transposer controls.
-- This is inconsistent with 'computed_input_to_nn', but trying to implement
-- diatonic transposition would make this not so direct any more.  And in
-- any case, "Cmd.MidiThru" shouldn't let through any transposers other than
-- octave.
direct_input_to_nn :: InputToNn
direct_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
direct_input_to_nn ScoreTime
pos (Pitch.Input KbdType
_ Pitch
pitch Frac
frac) = do
    Map Control Frac
controls <- RealTime -> Deriver State Error (Map Control Frac)
Derive.controls_at forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
pos
    let octaves :: Frac
octaves = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Frac
0 Control
Controls.octave Map Control Frac
controls
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ NoteNumber
nn forall a. Num a => a -> a -> a
+ forall a. Real a => a -> NoteNumber
Pitch.nn (Frac
frac forall a. Num a => a -> a -> a
+ Frac
octaves forall a. Num a => a -> a -> a
* Frac
12)
    where
    nn :: NoteNumber
nn = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ PitchClass -> PitchClass
Theory.semis_to_nn forall a b. (a -> b) -> a -> b
$
        Layout -> Pitch -> PitchClass
Theory.pitch_to_semis Layout
Theory.piano_layout Pitch
pitch

-- | Convert input to nn by going through note_to_call.  This works for
-- complicated scales that retune based on the environment but is more work.
computed_input_to_nn :: InputToNote -> (Pitch.Note -> Maybe Derive.ValCall)
    -> InputToNn
computed_input_to_nn :: (Environ -> Input -> Either PitchError Note)
-> (Note -> Maybe ValCall)
-> ScoreTime
-> Input
-> Deriver (Either PitchError NoteNumber)
computed_input_to_nn Environ -> Input -> Either PitchError Note
input_to_note Note -> Maybe ValCall
note_to_call ScoreTime
pos Input
input = do
    Environ
env <- Deriver Environ
Derive.get_environ
    case Environ -> Either PitchError (Note, ValCall)
get_call Environ
env of
        Left PitchError
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left PitchError
err
        Right (Note
note, ValCall
call) -> do
            RawPitch Any
pitch <- forall a. ScoreTime -> ValCall -> Deriver (RawPitch a)
Eval.apply_pitch ScoreTime
pos ValCall
call
            Map Control Frac
controls <- RealTime -> Deriver State Error (Map Control Frac)
Derive.controls_at forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
pos
            NoteNumber
nn <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right
                    (((Text
"evaluating note " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Note
note forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty) forall a b. (a -> b) -> a -> b
$
                Transposed -> Either PitchError NoteNumber
PSignal.pitch_nn forall a b. (a -> b) -> a -> b
$
                forall a b. PitchConfig -> RawPitch a -> RawPitch b
PSignal.apply_config (Environ -> Map Control Frac -> PitchConfig
PSignal.PitchConfig Environ
env Map Control Frac
controls) RawPitch Any
pitch
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right NoteNumber
nn
    where
    get_call :: Environ -> Either PitchError (Note, ValCall)
get_call Environ
env = do
        Note
note <- Environ -> Input -> Either PitchError Note
input_to_note Environ
env Input
input
        (Note
note,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall err a. err -> Maybe a -> Either err a
justErr (Note -> PitchError
DeriveT.UnparseableNote Note
note) (Note -> Maybe ValCall
note_to_call Note
note)

make_nn :: Maybe Pitch.NoteNumber -> Pitch.NoteNumber -> Maybe Pitch.NoteNumber
    -> Pitch.Frac -> Maybe Pitch.NoteNumber
make_nn :: Maybe NoteNumber
-> NoteNumber -> Maybe NoteNumber -> Frac -> Maybe NoteNumber
make_nn Maybe NoteNumber
mprev NoteNumber
nn Maybe NoteNumber
mnext Frac
frac
    | Frac
frac forall a. Eq a => a -> a -> Bool
== Frac
0 = forall a. a -> Maybe a
Just NoteNumber
nn
    | Frac
frac forall a. Ord a => a -> a -> Bool
> Frac
0 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NoteNumber
next -> NoteNumber -> NoteNumber -> NoteNumber
interpolate NoteNumber
nn NoteNumber
next) Maybe NoteNumber
mnext
    | Bool
otherwise = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NoteNumber
prev -> NoteNumber -> NoteNumber -> NoteNumber
interpolate NoteNumber
prev NoteNumber
nn) Maybe NoteNumber
mprev
    where
    interpolate :: NoteNumber -> NoteNumber -> NoteNumber
interpolate NoteNumber
low NoteNumber
high = forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
low NoteNumber
high (Frac -> NoteNumber
Pitch.NoteNumber Frac
frac)

-- *** diatonic

simple_kbd_to_scale :: DegreeMap -> Pitch.KbdType -> Pitch.Pitch
    -> Either DeriveT.PitchError Pitch.Semi
simple_kbd_to_scale :: DegreeMap -> KbdType -> Pitch -> Either PitchError PitchClass
simple_kbd_to_scale DegreeMap
dmap KbdType
kbd Pitch
pitch =
    DegreeMap -> Pitch -> PitchClass
pitch_to_semis DegreeMap
dmap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KbdType
-> PitchClass -> PitchClass -> Pitch -> Either PitchError Pitch
kbd_to_scale KbdType
kbd (DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap) PitchClass
0 Pitch
pitch

pitch_to_semis :: DegreeMap -> Pitch.Pitch -> Pitch.Semi
pitch_to_semis :: DegreeMap -> Pitch -> PitchClass
pitch_to_semis DegreeMap
dmap (Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
accs)) =
    (PitchClass
oct forall a. Num a => a -> a -> a
- DegreeMap -> PitchClass
dm_start_octave DegreeMap
dmap) forall a. Num a => a -> a -> a
* DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap
        forall a. Num a => a -> a -> a
+ PitchClass
pc forall a. Num a => a -> a -> a
- DegreeMap -> PitchClass
dm_start_pc DegreeMap
dmap forall a. Num a => a -> a -> a
+ PitchClass
accs

semis_to_pitch :: DegreeMap -> Pitch.Semi -> Pitch.Pitch
semis_to_pitch :: DegreeMap -> PitchClass -> Pitch
semis_to_pitch DegreeMap
dmap PitchClass
semis =
    PitchClass -> PitchClass -> Pitch -> Pitch
Pitch.add_pc PitchClass
per_oct (DegreeMap -> PitchClass
dm_start_pc DegreeMap
dmap) forall a b. (a -> b) -> a -> b
$
        PitchClass -> Degree -> Pitch
Pitch.Pitch (PitchClass
oct forall a. Num a => a -> a -> a
+ DegreeMap -> PitchClass
dm_start_octave DegreeMap
dmap) (PitchClass -> PitchClass -> Degree
Pitch.Degree PitchClass
pc PitchClass
0)
    where
    (PitchClass
oct, PitchClass
pc) = PitchClass
semis forall a. Integral a => a -> a -> (a, a)
`divMod` PitchClass
per_oct
    per_oct :: PitchClass
per_oct = DegreeMap -> PitchClass
dm_per_octave DegreeMap
dmap

kbd_to_scale :: Pitch.KbdType -> Pitch.PitchClass -> Pitch.PitchClass
    -> Pitch.Pitch -> Either DeriveT.PitchError Pitch.Pitch
kbd_to_scale :: KbdType
-> PitchClass -> PitchClass -> Pitch -> Either PitchError Pitch
kbd_to_scale KbdType
kbd PitchClass
pc_per_octave PitchClass
tonic =
    forall err a. err -> Maybe a -> Either err a
justErr PitchError
DeriveT.InvalidInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. KbdType -> PitchClass -> PitchClass -> Pitch -> Maybe Pitch
lookup_kbd_to_scale KbdType
kbd PitchClass
pc_per_octave PitchClass
tonic

-- | Convert an absolute Pitch in the input keyboard's layout to a relative
-- Pitch within a scale with the given number of diatonic steps per octave, or
-- Nothing if that key should have no pitch.
lookup_kbd_to_scale :: Pitch.KbdType -> Pitch.PitchClass -> Pitch.PitchClass
    -> Pitch.Pitch -> Maybe Pitch.Pitch
lookup_kbd_to_scale :: KbdType -> PitchClass -> PitchClass -> Pitch -> Maybe Pitch
lookup_kbd_to_scale KbdType
kbd PitchClass
pc_per_octave PitchClass
tonic Pitch
pitch = case KbdType
kbd of
    KbdType
Pitch.PianoKbd -> PitchClass -> PitchClass -> Pitch -> Maybe Pitch
piano_kbd_pitch PitchClass
tonic PitchClass
pc_per_octave Pitch
pitch
    KbdType
Pitch.AsciiKbd -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PitchClass -> Pitch -> Pitch
ascii_kbd_pitch PitchClass
pc_per_octave Pitch
pitch

{- Scale octave doesn't match the kbd octave, but is absolute:

       C D E F G A B|C D E F G A B
    C  1 2 3 4 5 - - 1 2 3 4 5 - -
    D  - 1 2 3 4 5 - - 1 2 3 4 5 -
    E  - - 1 2 3 4 5 - - 1 2 3 4 5

    Piano:
       0 1 2 3 4 5 6 0 1 2 3 4 5 6 0
       C D E F G A B|C D E F G A B|C
       0 1 2 3 4 - - 0
       0 1 2 3 4 5 6 7 8 - - - - - 0
-}

-- | The MIDI kbd is absolute.  This means that relative scales start on
-- different keys rather than all starting on C.  For example, in C major
-- C produces the first scale degree, while in D major D produces the first
-- scale degree.
--
-- In addition, if the scale octave is not an even multiple of the kbd octave
-- (7), the extra notes produce Nothing.  This check has to be done to
-- the relative PitchClass.  That way, a D on a 6 note scale starting on D is
-- 1, and a C is Nothing.  Thus, the returned Pitch is relative to the given
-- tonic, so it should be formatted as-is, without the key.
piano_kbd_pitch :: Pitch.PitchClass -> Pitch.PitchClass -> Pitch.Pitch
    -> Maybe Pitch.Pitch
piano_kbd_pitch :: PitchClass -> PitchClass -> Pitch -> Maybe Pitch
piano_kbd_pitch PitchClass
tonic PitchClass
pc_per_octave (Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
accs))
    | PitchClass
relative_pc forall a. Ord a => a -> a -> Bool
>= PitchClass
pc_per_octave = forall a. Maybe a
Nothing
    | Bool
otherwise =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PitchClass -> Degree -> Pitch
Pitch.Pitch (PitchClass
oct1 forall a. Num a => a -> a -> a
+ PitchClass
oct_diff) (PitchClass -> PitchClass -> Degree
Pitch.Degree PitchClass
relative_pc PitchClass
accs)
    where
    (PitchClass
oct1, PitchClass
pc1) = PitchClass
-> PitchClass
-> PitchClass
-> PitchClass
-> (PitchClass, PitchClass)
adjust_octave PitchClass
pc_per_octave PitchClass
7 PitchClass
oct PitchClass
pc
    (PitchClass
oct_diff, PitchClass
relative_pc) = (PitchClass
pc1 forall a. Num a => a -> a -> a
- PitchClass
tonic) forall a. Integral a => a -> a -> (a, a)
`divMod` PitchClass
max_pc
    max_pc :: PitchClass
max_pc = forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchClass
pc_per_octave forall a. Fractional a => a -> a -> a
/ Frac
7) forall a. Num a => a -> a -> a
* PitchClass
7

-- | The ASCII kbd is relative.  This means that relative scales always start
-- on \"C\".  So the tonic note of a key in a relative scale is irrelevant,
-- C major and D major both start in the same place.  Of course, they produce
-- different frequencies, but that's the responsibility of
-- 'Scale.scale_note_to_call'.
--
-- Unlike 'absolute_to_pitch', if the scale octave is not an even multiple of
-- the kbd octave (10), the extra notes wrap to the next highest octave.
ascii_kbd_pitch :: Pitch.PitchClass -> Pitch.Pitch -> Pitch.Pitch
ascii_kbd_pitch :: PitchClass -> Pitch -> Pitch
ascii_kbd_pitch PitchClass
pc_per_octave (Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
accs)) =
    PitchClass -> Degree -> Pitch
Pitch.Pitch (PitchClass
add_oct forall a. Num a => a -> a -> a
+ PitchClass
oct1) (PitchClass -> PitchClass -> Degree
Pitch.Degree PitchClass
pc2 PitchClass
accs)
    where
    (PitchClass
oct1, PitchClass
pc1) = PitchClass
-> PitchClass
-> PitchClass
-> PitchClass
-> (PitchClass, PitchClass)
adjust_octave PitchClass
pc_per_octave PitchClass
10 PitchClass
oct PitchClass
pc
    -- If the scale is shorter than the kbd, go up to the next octave on
    -- the same row.
    (PitchClass
add_oct, PitchClass
pc2) = PitchClass
pc1 forall a. Integral a => a -> a -> (a, a)
`divMod` PitchClass
pc_per_octave

-- | Try to fit a note from a keyboard into a scale.  Round the note up to the
-- nearest multiple of the keyboard octave and adjust the octave accordingly.
adjust_octave :: Pitch.PitchClass -> Pitch.PitchClass -> Pitch.Octave
    -> Pitch.PitchClass -> (Pitch.Octave, Pitch.PitchClass)
adjust_octave :: PitchClass
-> PitchClass
-> PitchClass
-> PitchClass
-> (PitchClass, PitchClass)
adjust_octave PitchClass
pc_per_octave PitchClass
kbd_per_octave PitchClass
oct PitchClass
pc =
    (PitchClass
oct2, PitchClass
offset forall a. Num a => a -> a -> a
* PitchClass
kbd_per_octave forall a. Num a => a -> a -> a
+ PitchClass
pc)
    where
    rows :: PitchClass
rows = forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchClass
pc_per_octave forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral PitchClass
kbd_per_octave
    (PitchClass
oct2, PitchClass
offset) = PitchClass
oct forall a. Integral a => a -> a -> (a, a)
`divMod` PitchClass
rows


-- ** call_doc

call_doc :: Set ScoreT.Control -> DegreeMap -> Doc.Doc -> Derive.DocumentedCall
call_doc :: Set Control -> DegreeMap -> Doc -> DocumentedCall
call_doc Set Control
transposers DegreeMap
dmap Doc
doc =
    Set Control
-> Doc -> [(Doc, Doc)] -> DocumentedCall -> DocumentedCall
annotate_call_doc Set Control
transposers Doc
doc [(Doc, Doc)]
fields DocumentedCall
default_scale_degree_doc
    where
    fields :: [(Doc, Doc)]
fields
        | forall a. Vector a -> Bool
Vector.null Vector Note
notes = []
        | Bool
otherwise = [(Doc
"range", forall a. Pretty a => a -> Doc
Doc.pretty Note
bottom forall a. Semigroup a => a -> a -> a
<> Doc
" to " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Doc.pretty Note
top)]
        where
        bottom :: Note
bottom = Vector Note
notes forall a. Vector a -> PitchClass -> a
Vector.! PitchClass
0
        top :: Note
top = Vector Note
notes forall a. Vector a -> PitchClass -> a
Vector.! (forall a. Vector a -> PitchClass
Vector.length Vector Note
notes forall a. Num a => a -> a -> a
- PitchClass
1)
        notes :: Vector Note
notes = DegreeMap -> Vector Note
dm_to_note DegreeMap
dmap

-- | Documentation of the standard 'Call.Pitch.scale_degree'.
default_scale_degree_doc :: Derive.DocumentedCall
default_scale_degree_doc :: DocumentedCall
default_scale_degree_doc = (Scale -> PitchNn -> PitchNote -> ValCall) -> DocumentedCall
scale_degree_doc Scale -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree

scale_degree_doc ::
    (PSignal.Scale -> Scale.PitchNn -> Scale.PitchNote -> Derive.ValCall)
    -> Derive.DocumentedCall
scale_degree_doc :: (Scale -> PitchNn -> PitchNote -> ValCall) -> DocumentedCall
scale_degree_doc Scale -> PitchNn -> PitchNote -> ValCall
scale_degree =
    ValCall -> DocumentedCall
Derive.extract_val_doc forall a b. (a -> b) -> a -> b
$ Scale -> PitchNn -> PitchNote -> ValCall
scale_degree Scale
PSignal.no_scale forall {p} {b}. p -> Either PitchError b
err forall {p} {b}. p -> Either PitchError b
err
    where err :: p -> Either PitchError b
err p
_ = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> PitchError
PSignal.PitchError Text
"it was just an example!"

annotate_call_doc :: Set ScoreT.Control -> Doc.Doc -> [(Doc.Doc, Doc.Doc)]
    -> Derive.DocumentedCall -> Derive.DocumentedCall
annotate_call_doc :: Set Control
-> Doc -> [(Doc, Doc)] -> DocumentedCall -> DocumentedCall
annotate_call_doc Set Control
transposers Doc
doc [(Doc, Doc)]
fields = Doc -> DocumentedCall -> DocumentedCall
prepend_doc Doc
extra_doc
    where
    extra_doc :: Doc
extra_doc = Doc
doc forall a. Semigroup a => a -> a -> a
<> Doc
"\n\n" forall a. Semigroup a => a -> a -> a
<> [(Doc, Doc)] -> Doc
join ([(Doc, Doc)]
transposers_field forall a. [a] -> [a] -> [a]
++ [(Doc, Doc)]
fields)
    transposers_field :: [(Doc, Doc)]
transposers_field =
        [(Doc
"transposers", Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Set Control
transposers) |
            Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set Control
transposers)]
    join :: [(Doc, Doc)] -> Doc
join = forall a. (Textlike a, Monoid a, IsString a) => [a] -> a
Texts.enumeration
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Doc
k, Doc
v) -> Doc
k forall a. Semigroup a => a -> a -> a
<> Doc
": " forall a. Semigroup a => a -> a -> a
<> Doc
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=Doc
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)

add_doc :: Doc.Doc -> Scale.Scale -> Scale.Scale
add_doc :: Doc -> Scale -> Scale
add_doc Doc
doc Scale
scale = Scale
scale
    { scale_call_doc :: DocumentedCall
Scale.scale_call_doc = Doc -> DocumentedCall -> DocumentedCall
prepend_doc Doc
doc (Scale -> DocumentedCall
Scale.scale_call_doc Scale
scale) }

-- *** DocumentedCall

-- | Prepend a bit of text to the documentation.
prepend_doc :: Doc.Doc -> Derive.DocumentedCall -> Derive.DocumentedCall
prepend_doc :: Doc -> DocumentedCall -> DocumentedCall
prepend_doc Doc
text = (Doc -> Doc) -> DocumentedCall -> DocumentedCall
modify_doc ((Doc
text forall a. Semigroup a => a -> a -> a
<> Doc
"\n") <>)

modify_doc :: (Doc.Doc -> Doc.Doc) -> Derive.DocumentedCall
    -> Derive.DocumentedCall
modify_doc :: (Doc -> Doc) -> DocumentedCall -> DocumentedCall
modify_doc Doc -> Doc
modify (Derive.DocumentedCall CallName
name CallDoc
doc) =
    CallName -> CallDoc -> DocumentedCall
Derive.DocumentedCall CallName
name (CallDoc -> CallDoc
annotate CallDoc
doc)
    where
    annotate :: CallDoc -> CallDoc
annotate (Derive.CallDoc Module
module_ Tags
tags Doc
cdoc [ArgDoc]
args) =
        Module -> Tags -> Doc -> [ArgDoc] -> CallDoc
Derive.CallDoc Module
module_ Tags
tags (Doc -> Doc
modify Doc
cdoc) [ArgDoc]
args

-- * util

no_enharmonics :: Derive.Enharmonics
no_enharmonics :: Enharmonics
no_enharmonics Environ
_ Note
_ = forall a b. b -> Either a b
Right []

-- | Like 'read_environ_', but with a simpler parser.
read_environ :: (Typecheck.Typecheck a, ShowVal.ShowVal a)
    => (a -> Maybe val)
    -> Maybe val -- ^ if Just, a missing value gets this, otherwise error
    -> Env.Key -> Env.Environ -> Either DeriveT.PitchError val
read_environ :: forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe val -> Text -> Environ -> Either PitchError val
read_environ a -> Maybe val
parse Maybe val
maybe_deflt =
    forall a val.
(Typecheck a, ShowVal a) =>
(a -> Either (Maybe Text) val)
-> Maybe (Either PitchError val)
-> Text
-> Environ
-> Either PitchError val
read_environ_ (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a. Maybe a
Nothing) forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe val
parse) (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe val
maybe_deflt)

-- | Like 'read_environ', except the default is given to the parse function.
read_environ_default :: (Typecheck.Typecheck a, ShowVal.ShowVal a) =>
    (a -> Maybe val) -> Maybe a
    -> Env.Key -> Env.Environ -> Either DeriveT.PitchError val
read_environ_default :: forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe a -> Text -> Environ -> Either PitchError val
read_environ_default a -> Maybe val
parse Maybe a
maybe_deflt Text
name =
    forall a val.
(Typecheck a, ShowVal a) =>
(a -> Either (Maybe Text) val)
-> Maybe (Either PitchError val)
-> Text
-> Environ
-> Either PitchError val
read_environ_ (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a. Maybe a
Nothing) forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe val
parse)
        (a -> Either PitchError val
parse_default forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
maybe_deflt) Text
name
    where
    parse_default :: a -> Either PitchError val
parse_default a
val = case a -> Maybe val
parse a
val of
        Just val
a -> forall a b. b -> Either a b
Right val
a
        Maybe val
Nothing -> forall {b}. Text -> Either PitchError b
environ_error forall a b. (a -> b) -> a -> b
$
            Text
"can't parse default: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val a
val
    environ_error :: Text -> Either PitchError b
environ_error = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text -> PitchError
DeriveT.EnvironError Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

-- | Read and parse an environ value, or throw a ScaleError.
-- This takes a parse function in addition to the usual Typecheck, because
-- scales and keys don't use use Typecheck, beyond ensuring it's a string.
read_environ_ :: (Typecheck.Typecheck a, ShowVal.ShowVal a)
    => (a -> Either (Maybe Text) val) -> Maybe (Either PSignal.PitchError val)
    -> Env.Key -> Env.Environ -> Either DeriveT.PitchError val
read_environ_ :: forall a val.
(Typecheck a, ShowVal a) =>
(a -> Either (Maybe Text) val)
-> Maybe (Either PitchError val)
-> Text
-> Environ
-> Either PitchError val
read_environ_ a -> Either (Maybe Text) val
parse Maybe (Either PitchError val)
maybe_deflt Text
name Environ
env = case forall a. Typecheck a => Text -> Environ -> Either LookupError a
Env.get_val Text
name Environ
env of
    Left (Env.WrongType Type
expected) ->
        forall {b}. Text -> Either PitchError b
environ_error (Text
"expected type " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Type
expected)
    Left LookupError
Env.NotFound -> case Maybe (Either PitchError val)
maybe_deflt of
        Maybe (Either PitchError val)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> PitchError
DeriveT.EnvironError Text
name forall a. Maybe a
Nothing
        Just Either PitchError val
deflt -> Either PitchError val
deflt
    Right a
val -> a -> Either PitchError val
parse_val a
val
    where
    parse_val :: a -> Either PitchError val
parse_val a
val = case a -> Either (Maybe Text) val
parse a
val of
        Right val
a -> forall a b. b -> Either a b
Right val
a
        Left Maybe Text
msg -> forall {b}. Text -> Either PitchError b
environ_error forall a b. (a -> b) -> a -> b
$ forall a. ShowVal a => a -> Text
ShowVal.show_val a
val forall a. Semigroup a => a -> a -> a
<> Text
": "
            forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a -> a
fromMaybe Text
"can't parse" Maybe Text
msg
    environ_error :: Text -> Either PitchError b
environ_error = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text -> PitchError
DeriveT.EnvironError Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just


-- ** keys

environ_key :: Env.Environ -> Maybe Pitch.Key
environ_key :: Environ -> Maybe Key
environ_key = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Key
Pitch.Key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.key

-- | Find a key in a map, or throw a ScaleError.
get_key :: key -> Map Pitch.Key key -> Maybe Pitch.Key
    -> Either DeriveT.PitchError key
get_key :: forall key.
key -> Map Key key -> Maybe Key -> Either PitchError key
get_key key
deflt Map Key key
_ Maybe Key
Nothing = forall a b. b -> Either a b
Right key
deflt
get_key key
_ Map Key key
keys (Just Key
key) = forall err a. err -> Maybe a -> Either err a
justErr (Key -> PitchError
key_error Key
key) (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key Map Key key
keys)

lookup_key :: key -> Map Pitch.Key key -> Maybe Pitch.Key -> Maybe key
lookup_key :: forall key. key -> Map Key key -> Maybe Key -> Maybe key
lookup_key key
deflt Map Key key
_ Maybe Key
Nothing = forall a. a -> Maybe a
Just key
deflt
lookup_key key
_ Map Key key
keys (Just Key
key) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key Map Key key
keys

key_error :: Pitch.Key -> DeriveT.PitchError
key_error :: Key -> PitchError
key_error (Pitch.Key Text
key) =
    Text -> Maybe Text -> PitchError
DeriveT.EnvironError Text
EnvKey.key (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"unknown key: " forall a. Semigroup a => a -> a -> a
<> Text
key)