{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE DeriveLift, StandaloneDeriving, TemplateHaskell #-}
module Composition.Notes (
Accidental (..),
Natural_note_name (..),
Note (..),
Note_name (..),
Note_name' (..),
Rat,
Simultaneous (..),
Time (..),
Time_and_position (..),
construct_note_name,
deconstruct_note_name,
ly,
measure_length,
sequential_length,
simultaneous_length,
subdivision) where
import Control.Monad.Except (MonadError (..))
import Control.Monad.RWS.Strict (RWS, RWST (..), runRWS)
import Control.Monad.State.Strict (MonadState (..), modify)
import Control.Monad.Writer.Strict (MonadWriter (..))
import Data.Char (isDigit)
import Data.Maybe (fromJust)
import Data.Ratio ((%), Ratio)
import Data.Tuple (swap)
import Language.Haskell.TH (Exp, Q)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax (Lift (..))
data Accidental = Flat | Natural | Sharp
data Char' = Delimiter_char Token | Nat_char Char | Negation_char | Space_char
data Counter = Counter Integer
data Natural_note_name = C_natural | D_natural | E_natural | F_natural | G_natural | A_natural | B_natural
data Note = Note Int Note_name
data Note_name =
C_flat |
C |
C_sharp |
D_flat |
D |
D_sharp |
E_flat |
E |
F_flat |
E_sharp |
F |
F_sharp |
G_flat |
G |
G_sharp |
A_flat |
A |
A_sharp |
B_flat |
B |
B_sharp
data Note_name' =
Note_name' Natural_note_name Accidental
type Parser = WST Counter [Token] Maybe
type Rat = Ratio Int
data Simultaneous = Simultaneous [Note] Rat
data Time = Time [Int] Int
data Time_and_position = Time_and_position Time Rat
data Token =
Dot_token |
End_token |
Flat_token |
Left_angular_token |
Nat_token Int |
Negation_token |
Note_name_token Natural_note_name |
Right_angular_token |
Sharp_token |
Tie_token
type Tokeniser = WS [Token] [Char']
type WS output state = RWS () output state
type WST = RWST ()
infixl 3 <+>
(<+>) :: Parser t -> Parser t -> Parser t
parse_0 <+> parse_1 =
wst
(\tokens ->
case (runWST parse_0 tokens, runWST parse_1 tokens) of
(Nothing, Nothing) -> Nothing
(Nothing, Just result) -> Just result
(Just result, Nothing) -> Just result
(Just result_0, Just result_1) ->
case compare (get_token_counter result_0) (get_token_counter result_1) of
LT -> Just result_1
EQ -> Nothing
GT -> Just result_0)
deriving instance Enum Natural_note_name
instance Enum Note where
fromEnum (Note octave note_name) =
(
21 * octave +
fromEnum note_name -
case note_name of
C_flat -> 2
B_sharp -> 0
_ -> 1)
toEnum i =
let
octave = div i 21
in
case mod i 21 of
19 -> Note (1 + octave) C_flat
20 -> Note octave B_sharp
j -> Note octave (toEnum (1 + j))
deriving instance Enum Note_name
deriving instance Eq Accidental
deriving instance Eq Counter
deriving instance Eq Natural_note_name
deriving instance Eq Note
deriving instance Eq Note_name
deriving instance Eq Note_name'
deriving instance Eq Token
deriving instance Lift Note
deriving instance Lift Note_name
deriving instance Lift Simultaneous
instance Monoid Counter where
mempty = 0
instance Num Counter where
Counter i * Counter j = Counter (i * j)
Counter i + Counter j = Counter (i + j)
abs (Counter i) = Counter (abs i)
fromInteger i = Counter i
negate (Counter i) = Counter (negate i)
signum (Counter i) = Counter (signum i)
deriving instance Ord Counter
instance Ord Note where
compare (Note octave_0 note_name_0) (Note octave_1 note_name_1) =
case compare octave_0 octave_1 of
LT ->
case (note_name_0, note_name_1) of
(B_sharp, C_flat) -> GT
_ -> LT
EQ -> compare note_name_0 note_name_1
GT ->
case (note_name_0, note_name_1) of
(C_flat, B_sharp) -> LT
_ -> GT
deriving instance Ord Note_name
instance Semigroup Counter where
(<>) = (+)
deriving instance Show Accidental
deriving instance Show Char'
deriving instance Show Counter
deriving instance Show Natural_note_name
deriving instance Show Note
deriving instance Show Note_name
deriving instance Show Note_name'
deriving instance Show Simultaneous
deriving instance Show Time
deriving instance Show Time_and_position
deriving instance Show Token
add_token :: Token -> Tokeniser ()
add_token token = tell [token]
certain_token :: Token -> Token -> Maybe ()
certain_token token token' =
case token == token' of
False -> Nothing
True -> Just ()
classify_char :: Char -> Char'
classify_char c =
case c of
' ' -> Space_char
'#' -> Delimiter_char Sharp_token
'-' -> Negation_char
'.' -> Delimiter_char Dot_token
'<' -> Delimiter_char Left_angular_token
'>' -> Delimiter_char Right_angular_token
'A' -> Delimiter_char (Note_name_token A_natural)
'B' -> Delimiter_char (Note_name_token B_natural)
'C' -> Delimiter_char (Note_name_token C_natural)
'D' -> Delimiter_char (Note_name_token D_natural)
'E' -> Delimiter_char (Note_name_token E_natural)
'F' -> Delimiter_char (Note_name_token F_natural)
'G' -> Delimiter_char (Note_name_token G_natural)
'b' -> Delimiter_char Flat_token
'~' -> Delimiter_char Tie_token
_ ->
case isDigit c of
False -> error "Invalid character."
True -> Nat_char c
construct_note_name :: Note_name' -> Note_name
construct_note_name note_name = fromJust (lookup note_name (swap <$> note_names))
deconstruct_note_name :: Note_name -> Note_name'
deconstruct_note_name note_name = fromJust (lookup note_name note_names)
gather_nat :: Tokeniser String
gather_nat =
do
maybe_char <- get_char 0
case maybe_char of
Just (Nat_char c) ->
do
next_char
i <- gather_nat
return (c : i)
_ -> return ""
get_char :: Integer -> Tokeniser (Maybe Char')
get_char i = index i <$> get
get_token_counter :: (t, [Token], Counter) -> Counter
get_token_counter (_, _, token_counter) = token_counter
index :: Integer -> [t] -> Maybe t
index i x =
case x of
[] -> Nothing
y : z ->
case i of
0 -> Just y
_ -> index (i - 1) z
invalid_template_location :: String -> Q t
invalid_template_location = template_error "Invalid location for template ly."
ly :: QuasiQuoter
ly = QuasiQuoter ly_exp invalid_template_location invalid_template_location invalid_template_location
ly_exp :: String -> Q Exp
ly_exp = parse parse_sequential
measure_length :: Time -> Rat
measure_length (Time numerator denominator) = product numerator % denominator
nat_token :: Token -> Maybe Int
nat_token token =
case token of
Nat_token i -> Just i
_ -> Nothing
next_char :: Tokeniser ()
next_char = modify tail
note_name_token :: Token -> Maybe Natural_note_name
note_name_token token =
case token of
Note_name_token natural_note_name -> Just natural_note_name
_ -> Nothing
note_names :: [(Note_name, Note_name')]
note_names =
[
(C_flat, Note_name' C_natural Flat),
(C, Note_name' C_natural Natural),
(C_sharp, Note_name' C_natural Sharp),
(D_flat, Note_name' D_natural Flat),
(D, Note_name' D_natural Natural),
(D_sharp, Note_name' D_natural Sharp),
(E_flat, Note_name' E_natural Flat),
(E, Note_name' E_natural Natural),
(E_sharp, Note_name' E_natural Sharp),
(F_flat, Note_name' F_natural Flat),
(F, Note_name' F_natural Natural),
(F_sharp, Note_name' F_natural Sharp),
(G_flat, Note_name' G_natural Flat),
(G, Note_name' G_natural Natural),
(G_sharp, Note_name' G_natural Sharp),
(A_flat, Note_name' A_natural Flat),
(A, Note_name' A_natural Natural),
(A_sharp, Note_name' A_natural Sharp),
(B_flat, Note_name' B_natural Flat),
(B, Note_name' B_natural Natural),
(B_sharp, Note_name' B_natural Sharp)]
parse :: Lift t => Parser t -> String -> Q Exp
parse parse_t text =
let
x = parse' parse_t (tokenise text)
in
[e|x|]
parse' :: Parser t -> [Token] -> t
parse' parse_t tokens =
case runWST (parse_end parse_t) tokens of
Nothing -> template_error "Parse error."
Just (x, _, _) -> x
parse_accidental :: Parser Accidental
parse_accidental = parse_flat <+> parse_natural <+> parse_sharp
parse_angular :: Parser t -> Parser t
parse_angular = parse_brackets Left_angular_token Right_angular_token
parse_base_length :: Parser Rat
parse_base_length = (%) 1 <$> parse_nat
parse_brackets :: Token -> Token -> Parser t -> Parser t
parse_brackets left_bracket right_bracket parse_t =
do
parse_token left_bracket
x <- parse_t
parse_token right_bracket
return x
parse_dots :: Parser Int
parse_dots = length <$> parse_many (parse_token Dot_token)
parse_element :: Token -> Parser t -> Parser t
parse_element separator parse_t =
do
parse_token separator
parse_t
parse_empty :: Parser [t]
parse_empty = return []
parse_end :: Parser t -> Parser t
parse_end parse_t =
do
x <- parse_t
parse_token End_token
return x
parse_flat :: Parser Accidental
parse_flat =
do
parse_token Flat_token
return Flat
parse_int :: Parser Int
parse_int = parse_negative_int <+> parse_nat
parse_length :: Parser Rat
parse_length = sum <$> parse_list Tie_token parse_simple_length
parse_list :: Token -> Parser t -> Parser [t]
parse_list separator parse_t = (:) <$> parse_t <*> parse_many (parse_element separator parse_t)
parse_many :: Parser t -> Parser [t]
parse_many parse_t = parse_empty <+> parse_some parse_t
parse_nat :: Parser Int
parse_nat = parse_token' nat_token
parse_natural :: Parser Accidental
parse_natural = return Natural
parse_natural_note_name :: Parser Natural_note_name
parse_natural_note_name = parse_token' note_name_token
parse_negative_int :: Parser Int
parse_negative_int =
do
parse_token Negation_token
i <- parse_nat
return (negate i)
parse_note :: Parser Note
parse_note =
do
note_name <- parse_note_name
octave <- parse_int
return (Note octave note_name)
parse_note_name :: Parser Note_name
parse_note_name = construct_note_name <$> (Note_name' <$> parse_natural_note_name <*> parse_accidental)
parse_notes :: Parser [Note]
parse_notes = parse_angular (parse_many parse_note)
parse_sequential :: Parser [Simultaneous]
parse_sequential = parse_many parse_simultaneous
parse_sharp :: Parser Accidental
parse_sharp =
do
parse_token Sharp_token
return Sharp
parse_simple_length :: Parser Rat
parse_simple_length =
do
base_length <- parse_base_length
dots <- parse_dots
return (base_length * (2 - 1 / 2 ^ dots))
parse_simultaneous :: Parser Simultaneous
parse_simultaneous = Simultaneous <$> parse_notes <*> parse_length
parse_some :: Parser t -> Parser [t]
parse_some parse_t = (:) <$> parse_t <*> parse_many parse_t
parse_token :: Token -> Parser ()
parse_token token = parse_token' (certain_token token)
parse_token' :: (Token -> Maybe t) -> Parser t
parse_token' f =
do
token : tokens <- get
case f token of
Nothing -> throwError ()
Just x ->
do
tell 1
put tokens
return x
runWS :: WS output state t -> state -> (t, state, output)
runWS f st = runRWS f () st
runWST :: WST output state f t -> state -> f (t, state, output)
runWST f = runRWST f ()
sequential_length :: [Simultaneous] -> Rat
sequential_length sequential = sum (simultaneous_length <$> sequential)
simultaneous_length :: Simultaneous -> Rat
simultaneous_length (Simultaneous _ len) = len
subdivision :: Time -> Time
subdivision (Time numerator denominator) =
case numerator of
[] -> Time [] (2 * denominator)
_ : numerator' -> Time numerator' denominator
template_error :: String -> t
template_error err = error ("Template error. " ++ err)
tokenise :: String -> [Token]
tokenise text =
let
((), _, tokens) = runWS tokenise' (classify_char <$> text)
in
tokens
tokenise' :: Tokeniser ()
tokenise' =
do
maybe_char <- get_char 0
maybe_char' <- get_char 1
case maybe_char of
Nothing -> add_token End_token
Just char ->
do
case char of
Delimiter_char token ->
do
add_token token
next_char
Nat_char c ->
case (c, maybe_char') of
('0', Just (Nat_char _)) -> template_error "Int starting with zero."
_ -> tokenise_nat
Negation_char ->
case maybe_char' of
Just (Nat_char c) ->
case c of
'0' -> template_error "Negation of int starting with zero."
_ ->
do
add_token Negation_token
next_char
_ -> template_error "Standalone negation sign."
Space_char -> next_char
tokenise'
tokenise_nat :: Tokeniser ()
tokenise_nat =
do
i <- gather_nat
add_token (Nat_token (read i))
wst :: (state -> f (t, state, output)) -> WST output state f t
wst f = RWST (\() -> f)