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

{-# LANGUAGE CPP #-}
-- | Parse the tscore language.
module Derive.TScore.Parse (
    -- * Parse
    parse_score
    , parse_allocation, unparse_allocations
    , default_call, default_namespace
    , show_block, show_block_track
    -- * Note
    , dot_note, tie_note
    -- * util
    , strip_comment
#ifdef TESTING
    , module Derive.TScore.Parse
#endif
) where
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Void as Void

import qualified Util.Control as Control
import qualified Util.P as P
import           Util.P ((<?>))
import qualified Util.Parse as Parse

import qualified Derive.Parse.Instruments as Instruments
import qualified Derive.TScore.T as T
import qualified Ui.Id as Id

import           Global
import           Types


-- | Parsing config.  Parsed 'T.Directive's can affect further parsing, which
-- is not very nice, but convenient for concise notation.
data Config = Config {
    -- | If true, notes with no call get the pitch as their call.
    Config -> Bool
_default_call :: !Bool
    } deriving (TrackNum -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: TrackNum -> Config -> ShowS
$cshowsPrec :: TrackNum -> Config -> ShowS
Show, Config -> Config -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq)

default_config :: Config
default_config :: Config
default_config = Bool -> Config
Config Bool
False

-- * parse

parse_score :: Text -> Either String T.Score
parse_score :: CallText -> Either String Score
parse_score = forall a. Parser a -> CallText -> Either String a
parse_text (forall a. Element a => Config -> Parser a
parse Config
default_config)

parse_text :: Parser a -> Text -> Either String a
parse_text :: forall a. Parser a -> CallText -> Either String a
parse_text Parser a
p = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
P.errorBundlePretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.parse (Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof) String
""

type Parser a = P.Parsec Void.Void Text a

get_pos :: Parser T.Pos
get_pos :: Parser Pos
get_pos = TrackNum -> Pos
T.Pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e. State s e -> TrackNum
P.stateOffset forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *). MonadParsec e s m => m (State s e)
P.getParserState

class Element a where
    parse :: Config -> Parser a
    unparse :: Config -> a -> Text

instance Element a => Element (T.Pos, a) where
    parse :: Config -> Parser (Pos, a)
parse Config
config = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Pos
get_pos forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Element a => Config -> Parser a
parse Config
config
    unparse :: Config -> (Pos, a) -> CallText
unparse Config
config = forall a. Element a => Config -> a -> CallText
unparse Config
config forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd

instance Element T.Score where
    parse :: Config -> Parser Score
parse Config
config = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pos, Toplevel)] -> Score
T.Score forall a b. (a -> b) -> a -> b
$ do
        Parser ()
p_whitespace
        forall state a. state -> ((state -> a) -> state -> a) -> a
Control.loop1 Config
config forall a b. (a -> b) -> a -> b
$ \Config -> ParsecT Void CallText Identity [(Pos, Toplevel)]
loop Config
config ->
            forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (forall a. Parser a -> Parser a
lexeme (forall a. Element a => Config -> Parser a
parse Config
config)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe (Pos, Toplevel)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
                Just (Pos, Toplevel)
toplevel -> ((Pos, Toplevel)
toplevel:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    Config -> ParsecT Void CallText Identity [(Pos, Toplevel)]
loop ([Directive] -> Config -> Config
update_config (Toplevel -> [Directive]
directives_of (forall a b. (a, b) -> b
snd (Pos, Toplevel)
toplevel)) Config
config)
    unparse :: Config -> Score -> CallText
unparse Config
config (T.Score [(Pos, Toplevel)]
toplevels) =
        [CallText] -> CallText
Text.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL forall {a}.
Element (a, Toplevel) =>
Config -> (a, Toplevel) -> (Config, CallText)
un Config
config [(Pos, Toplevel)]
toplevels
        where
        un :: Config -> (a, Toplevel) -> (Config, CallText)
un Config
config (a, Toplevel)
toplevel =
            ( [Directive] -> Config -> Config
update_config (Toplevel -> [Directive]
directives_of (forall a b. (a, b) -> b
snd (a, Toplevel)
toplevel)) Config
config
            , forall a. Element a => Config -> a -> CallText
unparse Config
config (a, Toplevel)
toplevel
            )

update_config :: [T.Directive] -> Config -> Config
update_config :: [Directive] -> Config -> Config
update_config [Directive]
directives Config
config
    | [Directive] -> Bool
default_call_set [Directive]
directives = Config
config { _default_call :: Bool
_default_call = Bool
True }
    | Bool
otherwise = Config
config

default_call_set :: [T.Directive] -> Bool
default_call_set :: [Directive] -> Bool
default_call_set [Directive]
directives = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null
    [() | T.Directive Pos
_ CallText
name Maybe CallText
_ <- [Directive]
directives, CallText
name forall a. Eq a => a -> a -> Bool
== CallText
default_call]

default_call :: Text
default_call :: CallText
default_call = CallText
"default-call"

directives_of :: T.Toplevel -> [T.Directive]
directives_of :: Toplevel -> [Directive]
directives_of (T.ToplevelDirective Directive
d) = [Directive
d]
directives_of Toplevel
_ = []

instance Element T.Toplevel where
    parse :: Config -> Parser Toplevel
parse Config
config = Directive -> Toplevel
T.ToplevelDirective forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Element a => Config -> Parser a
parse Config
config
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Block WrappedTracks -> Toplevel
T.BlockDefinition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Element a => Config -> Parser a
parse Config
config
    unparse :: Config -> Toplevel -> CallText
unparse Config
config = \case
        T.ToplevelDirective Directive
a -> forall a. Element a => Config -> a -> CallText
unparse Config
config Directive
a
        T.BlockDefinition Block WrappedTracks
a -> forall a. Element a => Config -> a -> CallText
unparse Config
config Block WrappedTracks
a

-- > ns/block = %directive "block title" [ ... ]
instance Element (T.Block T.WrappedTracks) where
    parse :: Config -> Parser (Block WrappedTracks)
parse Config
config = do
        BlockId
bid <- forall a. Parser a -> Parser a
lexeme (forall a. Element a => Config -> Parser a
parse Config
config)
        CallText -> Parser ()
keyword CallText
"="
        [Directive]
directives <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (forall a. Parser a -> Parser a
lexeme (forall a. Element a => Config -> Parser a
parse Config
config))
        CallText
title <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option CallText
"" (forall a. Parser a -> Parser a
lexeme ParsecT Void CallText Identity CallText
p_string)
        WrappedTracks
tracks <- forall a. Element a => Config -> Parser a
parse ([Directive] -> Config -> Config
update_config [Directive]
directives Config
config)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall tracks.
BlockId -> [Directive] -> CallText -> tracks -> Block tracks
T.Block BlockId
bid [Directive]
directives CallText
title WrappedTracks
tracks
    unparse :: Config -> Block WrappedTracks -> CallText
unparse Config
config (T.Block BlockId
bid [Directive]
directives CallText
title WrappedTracks
tracks) =
        [CallText] -> CallText
Text.unwords forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallText -> Bool
Text.null) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [forall a. Element a => Config -> a -> CallText
unparse Config
config BlockId
bid, CallText
"="]
            , forall a b. (a -> b) -> [a] -> [b]
map (forall a. Element a => Config -> a -> CallText
unparse Config
config) [Directive]
directives
            , [if CallText -> Bool
Text.null CallText
title then CallText
"" else CallText -> CallText
un_string CallText
title]
            , [forall a. Element a => Config -> a -> CallText
unparse ([Directive] -> Config -> Config
update_config [Directive]
directives Config
config) WrappedTracks
tracks]
            ]

instance Element Id.BlockId where
    parse :: Config -> Parser BlockId
parse Config
_ = do
        CallText
a <- forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 Char -> Bool
Id.is_id_char
        Maybe CallText
mb <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'/' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 Char -> Bool
Id.is_id_char)
        let bid :: Id
bid = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Namespace -> CallText -> Id
Id.id Namespace
default_namespace CallText
a)
                (\CallText
b -> Namespace -> CallText -> Id
Id.id (CallText -> Namespace
Id.namespace CallText
a) CallText
b) Maybe CallText
mb
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"invalid BlockId: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> String
prettys Id
bid) forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ident a => Id -> Maybe a
Id.make Id
bid)
        forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"BlockId"
    unparse :: Config -> BlockId -> CallText
unparse Config
_ = BlockId -> CallText
show_block

show_block :: Id.BlockId -> Text
show_block :: BlockId -> CallText
show_block = Namespace -> Id -> CallText
Id.show_short Namespace
default_namespace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ident a => a -> Id
Id.unpack_id

show_block_track :: Id.BlockId -> TrackNum -> Text
show_block_track :: BlockId -> TrackNum -> CallText
show_block_track BlockId
block_id TrackNum
tracknum =
    BlockId -> CallText
show_block BlockId
block_id forall a. Semigroup a => a -> a -> a
<> CallText
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> CallText
showt TrackNum
tracknum

default_namespace :: Id.Namespace
default_namespace :: Namespace
default_namespace = CallText -> Namespace
Id.namespace CallText
"tscore"

instance Element T.WrappedTracks where
    parse :: Config -> Parser WrappedTracks
parse Config
config = Pos -> [Tracks Call] -> WrappedTracks
T.WrappedTracks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Pos
get_pos
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some (forall a. Parser a -> Parser a
lexeme (forall a. Element a => Config -> Parser a
parse Config
config))
    unparse :: Config -> WrappedTracks -> CallText
unparse Config
config (T.WrappedTracks Pos
_ [Tracks Call]
wrapped) =
        [CallText] -> CallText
Text.unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Element a => Config -> a -> CallText
unparse Config
config) [Tracks Call]
wrapped

instance Element (T.Tracks T.Call) where
    parse :: Config -> Parser (Tracks Call)
parse Config
config = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall call. [Track call] -> Tracks call
T.Tracks forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
lexeme ParsecT Void CallText Identity CallText
"[" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void CallText Identity [Track Call]
tracks forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Parser a -> Parser a
lexeme ParsecT Void CallText Identity CallText
"]"
        where
        tracks :: ParsecT Void CallText Identity [Track Call]
tracks = forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy1 (forall a. Parser a -> Parser a
lexeme (forall a. Element a => Config -> Parser a
parse Config
config))
            (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead (forall a. Parser a -> Parser a
lexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'>' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure () forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void CallText Identity CallText
"\">" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())))
    unparse :: Config -> Tracks Call -> CallText
unparse Config
config (T.Tracks [Track Call]
tracks) =
        CallText
"[" forall a. Semigroup a => a -> a -> a
<> [CallText] -> CallText
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Element a => Config -> a -> CallText
unparse Config
config) [Track Call]
tracks) forall a. Semigroup a => a -> a -> a
<> CallText
"]"

instance Element (T.Track T.Call) where
    parse :: Config -> Parser (Track Call)
parse Config
config = do
        Pos
pos <- Parser Pos
get_pos
        (CallText
key, CallText
title) <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option (CallText
"", CallText
"") forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ (,)
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'>' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile Char -> Bool
is_key_char)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CallText
">"<>) (ParsecT Void CallText Identity CallText
p_string forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile Char -> Bool
Id.is_id_char)
        [Directive]
directives <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ forall a. Element a => Config -> Parser a
parse Config
config
        [Token]
tokens <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ forall a. Element a => Config -> Parser a
parse Config
config
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ T.Track
            { track_key :: CallText
track_key = CallText
key
            , track_title :: CallText
track_title = CallText
title
            , track_directives :: [Directive]
track_directives = [Directive]
directives
            , track_tokens :: [Token]
track_tokens = [Token]
tokens
            , track_pos :: Pos
track_pos = Pos
pos
            }
    unparse :: Config -> Track Call -> CallText
unparse Config
config (T.Track CallText
key CallText
title [Directive]
directives [Token]
tokens Pos
_pos) =
        [CallText] -> CallText
Text.unwords forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallText -> Bool
Text.null) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            -- See 'T.track_title' for why this is so complicated.
            [ (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ if CallText
key forall a. Eq a => a -> a -> Bool
== CallText
"" Bool -> Bool -> Bool
&& CallText
title forall a. Eq a => a -> a -> Bool
== CallText
"" then CallText
""
                else CallText
">" forall a. Semigroup a => a -> a -> a
<> CallText
key forall a. Semigroup a => a -> a -> a
<> if CallText
" " CallText -> CallText -> Bool
`Text.isInfixOf` CallText
title
                    then CallText -> CallText
un_string (TrackNum -> CallText -> CallText
Text.drop TrackNum
1 CallText
title) else (TrackNum -> CallText -> CallText
Text.drop TrackNum
1 CallText
title)
            , forall a b. (a -> b) -> [a] -> [b]
map (forall a. Element a => Config -> a -> CallText
unparse Config
config) [Directive]
directives
            , forall a b. (a -> b) -> [a] -> [b]
map (forall a. Element a => Config -> a -> CallText
unparse Config
config) [Token]
tokens
            ]

is_key_char :: Char -> Bool
is_key_char :: Char -> Bool
is_key_char Char
c = Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"!@#$%^&*" :: [Char])
    -- Technically this could be `c /='"' && not (Id.is_id_char c)`, but I'll be
    -- more restrictive for now.

instance Element T.Directive where
    parse :: Config -> Parser Directive
parse Config
_ = do
        Pos
pos <- Parser Pos
get_pos
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'%'
        Pos -> CallText -> Maybe CallText -> Directive
T.Directive Pos
pos
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 (String -> Char -> Bool
not_in String
"=")
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'=' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void CallText Identity CallText
p_directive_value)
    unparse :: Config -> Directive -> CallText
unparse Config
_ (T.Directive Pos
_ CallText
lhs Maybe CallText
rhs) = CallText
"%" forall a. Semigroup a => a -> a -> a
<> CallText
lhs
        forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe CallText
"" ((CallText
"="<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallText -> CallText
unparse_directive_value) Maybe CallText
rhs

p_directive_value :: Parser Text
p_directive_value :: ParsecT Void CallText Identity CallText
p_directive_value = ParsecT Void CallText Identity CallText
p_multi_string forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void CallText Identity CallText
p_word

unparse_directive_value :: Text -> Text
unparse_directive_value :: CallText -> CallText
unparse_directive_value CallText
val
    | (Char -> Bool) -> CallText -> Bool
Text.any Char -> Bool
Char.isSpace CallText
val = CallText
"''\n" forall a. Semigroup a => a -> a -> a
<> CallText
val forall a. Semigroup a => a -> a -> a
<> CallText
"\n''"
    | Bool
otherwise = CallText
val

p_multi_string :: Parser Text
p_multi_string :: ParsecT Void CallText Identity CallText
p_multi_string = ParsecT Void CallText Identity CallText
"''" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void CallText Identity CallText
contents forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void CallText Identity CallText
"''"
    where
    contents :: ParsecT Void CallText Identity CallText
contents = CallText -> CallText
dedent forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallText -> [CallText] -> CallText
Text.intercalate CallText
"'" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ((:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void CallText Identity (Tokens CallText)
content forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many ParsecT Void CallText Identity (Tokens CallText)
chunk)
    content :: ParsecT Void CallText Identity (Tokens CallText)
content = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 (forall a. Eq a => a -> a -> Bool
/=Char
'\'')
    -- TODO this is inefficient, surely there's a way to takeWhile but look at
    -- the next char?
    chunk :: ParsecT Void CallText Identity (Tokens CallText)
chunk = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try forall a b. (a -> b) -> a -> b
$ ParsecT Void CallText Identity CallText
"'" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 (forall a. Eq a => a -> a -> Bool
/=Char
'\'')

dedent :: Text -> Text
dedent :: CallText -> CallText
dedent CallText
t = CallText -> CallText
Text.strip forall a b. (a -> b) -> a -> b
$ case CallText -> [CallText]
Text.lines ((Char -> Bool) -> CallText -> CallText
Text.dropWhile (forall a. Eq a => a -> a -> Bool
==Char
'\n') CallText
t) of
    [] -> CallText
""
    CallText
x : [CallText]
xs -> [CallText] -> CallText
Text.unlines (forall a b. (a -> b) -> [a] -> [b]
map (CallText -> CallText -> CallText
strip CallText
indent) (CallText
xforall a. a -> [a] -> [a]
:[CallText]
xs))
        where indent :: CallText
indent = (Char -> Bool) -> CallText -> CallText
Text.takeWhile Char -> Bool
Char.isSpace CallText
x
    where strip :: CallText -> CallText -> CallText
strip CallText
pref CallText
s = forall a. a -> Maybe a -> a
fromMaybe CallText
s forall a b. (a -> b) -> a -> b
$ CallText -> CallText -> Maybe CallText
Text.stripPrefix CallText
pref CallText
s

parse_allocation :: Text -> Either String Instruments.Allocation
parse_allocation :: CallText -> Either String Allocation
parse_allocation = forall a. Parser a -> CallText -> Either String a
parse_text Parser Allocation
Instruments.p_allocation

unparse_allocations :: [Instruments.Allocation] -> Text
unparse_allocations :: [Allocation] -> CallText
unparse_allocations =
    [CallText] -> CallText
Text.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Maybe Allocation, CallText)] -> [CallText]
Instruments.unparse_allocations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((, CallText
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)

type Token = T.Token T.Call (T.NPitch T.Pitch) T.NDuration T.Duration

instance Element Token where
    parse :: Config -> Parser Token
parse Config
config =
        forall call pitch ndur rdur.
Pos -> Barline -> Token call pitch ndur rdur
T.TBarline forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Pos
get_pos forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Element a => Config -> Parser a
parse Config
config
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall call pitch ndur rdur.
Pos -> Rest rdur -> Token call pitch ndur rdur
T.TRest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Pos
get_pos forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Element a => Config -> Parser a
parse Config
config
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall call pitch ndur rdur.
Pos -> Note call pitch ndur -> Token call pitch ndur rdur
T.TNote forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Pos
get_pos forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Element a => Config -> Parser a
parse Config
config
    unparse :: Config -> Token -> CallText
unparse Config
config (T.TBarline Pos
_ Barline
bar) = forall a. Element a => Config -> a -> CallText
unparse Config
config Barline
bar
    unparse Config
config (T.TNote Pos
_ Note Call (NPitch Pitch) NDuration
note) = forall a. Element a => Config -> a -> CallText
unparse Config
config Note Call (NPitch Pitch) NDuration
note
    unparse Config
config (T.TRest Pos
_ Rest Duration
rest) = forall a. Element a => Config -> a -> CallText
unparse Config
config Rest Duration
rest

instance Pretty Token where
    pretty :: Token -> CallText
pretty = forall a. Element a => Config -> a -> CallText
unparse Config
default_config

instance Pretty (T.Token T.CallText T.Pitch T.NDuration T.Duration) where
    pretty :: Token CallText Pitch NDuration Duration -> CallText
pretty = \case
        T.TNote Pos
_ Note CallText Pitch NDuration
note -> forall a. Pretty a => a -> CallText
pretty Note CallText Pitch NDuration
note
        T.TBarline Pos
_ Barline
bar -> forall a. Pretty a => a -> CallText
pretty Barline
bar
        T.TRest Pos
_ Rest Duration
rest -> forall a. Pretty a => a -> CallText
pretty Rest Duration
rest

-- ** barline

instance Element T.Barline where
    parse :: Config -> Parser Barline
parse Config
_ = TrackNum -> Barline
T.Barline forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CallText -> TrackNum
Text.length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 (forall a. Eq a => a -> a -> Bool
==Char
'|'))
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
';' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Barline
T.AssertCoincident)
    unparse :: Config -> Barline -> CallText
unparse Config
_ (T.Barline TrackNum
n)
        | TrackNum
n forall a. Ord a => a -> a -> Bool
>= TrackNum
1 = TrackNum -> CallText -> CallText
Text.replicate TrackNum
n CallText
"|"
        | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Barline <= 0: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TrackNum
n
    unparse Config
_ Barline
T.AssertCoincident = CallText
";"

instance Pretty T.Barline where pretty :: Barline -> CallText
pretty = forall a. Element a => Config -> a -> CallText
unparse Config
default_config

-- * Note

-- | Parse a note with a letter pitch.
--
-- > <call><oct><pitch><zero-dur><dur><dots><tie>
-- > call/  4    s      *         4    .     ~
-- >        ,    s                :1
--
-- oct is optional, but oct without pitch is not so useful, so pitch >=1 char.
--
-- > a a2 call/a2
-- > a2.
-- > a~ a2~
-- > "call with spaces"/
instance Element (T.Note T.Call (T.NPitch T.Pitch) T.NDuration) where
    parse :: Config -> Parser (Note Call (NPitch Pitch) NDuration)
parse Config
config
        -- I need this P.try because / is an empty note and I need to backtrack
        -- when it fails, to parse //.
        | Config -> Bool
_default_call Config
config = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try forall a b. (a -> b) -> a -> b
$ do
            Pos
pos <- Parser Pos
get_pos
            Maybe Call
call <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional forall a b. (a -> b) -> a -> b
$ forall a. Element a => Config -> Parser a
parse Config
config
            (NPitch Pitch
pitch, Bool
zero_dur, NDuration
dur) <-
                forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option (NPitch Pitch
empty_npitch, Bool
False, NDuration
empty_nduration) forall a b. (a -> b) -> a -> b
$ do
                    forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'/'
                    (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option NPitch Pitch
empty_npitch (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (forall a. Element a => Config -> Parser a
parse Config
config))
                         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void CallText Identity Bool
p_zero_dur
                         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Element a => Config -> Parser a
parse Config
config
            forall {m :: * -> *}.
(Monad m, Alternative m) =>
Pos
-> Maybe Call
-> NPitch Pitch
-> Bool
-> NDuration
-> m (Note Call (NPitch Pitch) NDuration)
make_note Pos
pos Maybe Call
call NPitch Pitch
pitch Bool
zero_dur NDuration
dur
        | Bool
otherwise = do
            Pos
pos <- Parser Pos
get_pos
            Maybe Call
call <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try forall a b. (a -> b) -> a -> b
$ forall a. Element a => Config -> Parser a
parse Config
config forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'/'
            -- I need a try, because if it starts with a number it could be
            -- an octave, or a duration.
            NPitch Pitch
pitch <- forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option NPitch Pitch
empty_npitch forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (forall a. Element a => Config -> Parser a
parse Config
config)
            Bool
zero_dur <- ParsecT Void CallText Identity Bool
p_zero_dur
            NDuration
dur <- forall a. Element a => Config -> Parser a
parse Config
config
            forall {m :: * -> *}.
(Monad m, Alternative m) =>
Pos
-> Maybe Call
-> NPitch Pitch
-> Bool
-> NDuration
-> m (Note Call (NPitch Pitch) NDuration)
make_note Pos
pos Maybe Call
call NPitch Pitch
pitch Bool
zero_dur NDuration
dur
        where
        p_zero_dur :: ParsecT Void CallText Identity Bool
p_zero_dur = forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option Bool
False (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'*' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
        make_note :: Pos
-> Maybe Call
-> NPitch Pitch
-> Bool
-> NDuration
-> m (Note Call (NPitch Pitch) NDuration)
make_note Pos
pos Maybe Call
call NPitch Pitch
pitch Bool
zero_dur NDuration
dur = do
            -- If I allow "" as a note, I can't get P.many of them.
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Note Call (NPitch Pitch) NDuration
note { note_pos :: Pos
T.note_pos = TrackNum -> Pos
T.Pos TrackNum
0 } forall a. Eq a => a -> a -> Bool
/= Note Call (NPitch Pitch) NDuration
empty_note)
            forall (m :: * -> *) a. Monad m => a -> m a
return Note Call (NPitch Pitch) NDuration
note
            where
            note :: Note Call (NPitch Pitch) NDuration
note = T.Note
                { note_call :: Call
note_call = forall a. a -> Maybe a -> a
fromMaybe (CallText -> Call
T.Call CallText
"") Maybe Call
call
                , note_pitch :: NPitch Pitch
note_pitch = NPitch Pitch
pitch
                , note_zero_duration :: Bool
note_zero_duration = Bool
zero_dur
                , note_duration :: NDuration
note_duration = NDuration
dur
                , note_pos :: Pos
note_pos = Pos
pos
                }
    unparse :: Config -> Note Call (NPitch Pitch) NDuration -> CallText
unparse Config
config (T.Note Call
call NPitch Pitch
pitch Bool
zero_dur NDuration
dur Pos
_pos)
        | Config -> Bool
_default_call Config
config =
            forall a. Element a => Config -> a -> CallText
unparse Config
config Call
call
            forall a. Semigroup a => a -> a -> a
<> if (NPitch Pitch
pitch, Bool
zero_dur, NDuration
dur) forall a. Eq a => a -> a -> Bool
== (NPitch Pitch, Bool, NDuration)
empty then CallText
"" else forall a. Monoid a => [a] -> a
mconcat
                [ CallText
"/"
                , forall a. Element a => Config -> a -> CallText
unparse Config
config NPitch Pitch
pitch
                , if Bool
zero_dur then CallText
"*" else CallText
""
                , forall a. Element a => Config -> a -> CallText
unparse Config
config NDuration
dur
                ]
        | Bool
otherwise = forall a. Monoid a => [a] -> a
mconcat
            [ if Call
call forall a. Eq a => a -> a -> Bool
== CallText -> Call
T.Call CallText
"" then CallText
"" else forall a. Element a => Config -> a -> CallText
unparse Config
config Call
call forall a. Semigroup a => a -> a -> a
<> CallText
"/"
            , forall a. Element a => Config -> a -> CallText
unparse Config
config NPitch Pitch
pitch
            , if Bool
zero_dur then CallText
"*" else CallText
""
            , forall a. Element a => Config -> a -> CallText
unparse Config
config NDuration
dur
            ]
        where
        empty :: (NPitch Pitch, Bool, NDuration)
empty = (NPitch Pitch
empty_npitch, Bool
False, NDuration
empty_nduration)

-- | This is the output from Check.check.
instance Pretty (T.Note T.CallText (Maybe Text) T.Time) where
    pretty :: Note CallText (Maybe CallText) Time -> CallText
pretty (T.Note CallText
call Maybe CallText
pitch Bool
_zero_dur Time
dur Pos
_pos) = forall a. Monoid a => [a] -> a
mconcat
        [ if CallText
call forall a. Eq a => a -> a -> Bool
== CallText
"" then CallText
"" else CallText
call forall a. Semigroup a => a -> a -> a
<> CallText
"/"
        , forall a. a -> Maybe a -> a
fromMaybe CallText
"" Maybe CallText
pitch, forall a. Pretty a => a -> CallText
pretty Time
dur
        ]

instance Pretty (T.Note T.CallText T.Pitch T.NDuration) where
    pretty :: Note CallText Pitch NDuration -> CallText
pretty (T.Note CallText
call Pitch
pitch Bool
_zero_dur NDuration
dur Pos
_pos) = forall a. Monoid a => [a] -> a
mconcat
        [ if CallText
call forall a. Eq a => a -> a -> Bool
== CallText
"" then CallText
"" else CallText
call forall a. Semigroup a => a -> a -> a
<> CallText
"/"
        , forall a. Element a => Config -> a -> CallText
unparse Config
default_config Pitch
pitch, forall a. Element a => Config -> a -> CallText
unparse Config
default_config NDuration
dur
        ]

instance Element (T.NPitch T.Pitch) where
    parse :: Config -> ParsecT Void CallText Identity (NPitch Pitch)
parse Config
config =
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'^' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall pitch. NPitch pitch
T.CopyFrom forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall pitch. pitch -> NPitch pitch
T.NPitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Element a => Config -> Parser a
parse Config
config
    unparse :: Config -> NPitch Pitch -> CallText
unparse Config
config = \case
        NPitch Pitch
T.CopyFrom -> CallText
"^"
        T.NPitch Pitch
pitch -> forall a. Element a => Config -> a -> CallText
unparse Config
config Pitch
pitch

empty_note :: T.Note T.Call (T.NPitch T.Pitch) T.NDuration
empty_note :: Note Call (NPitch Pitch) NDuration
empty_note = T.Note
    { note_call :: Call
note_call = CallText -> Call
T.Call CallText
""
    , note_pitch :: NPitch Pitch
note_pitch = NPitch Pitch
empty_npitch
    , note_zero_duration :: Bool
note_zero_duration = Bool
False
    , note_duration :: NDuration
note_duration = NDuration
empty_nduration
    , note_pos :: Pos
note_pos = TrackNum -> Pos
T.Pos TrackNum
0
    }

empty_nduration :: T.NDuration
empty_nduration :: NDuration
empty_nduration = Duration -> NDuration
T.NDuration Duration
empty_duration

empty_duration :: T.Duration
empty_duration :: Duration
empty_duration = T.Duration
    { dur_int1 :: Maybe TrackNum
dur_int1 = forall a. Maybe a
Nothing
    , dur_int2 :: Maybe TrackNum
dur_int2 = forall a. Maybe a
Nothing
    , dur_dots :: TrackNum
dur_dots = TrackNum
0
    , dur_tie :: Bool
dur_tie = Bool
False
    }

empty_npitch :: T.NPitch T.Pitch
empty_npitch :: NPitch Pitch
empty_npitch = forall pitch. pitch -> NPitch pitch
T.NPitch Pitch
empty_pitch

empty_pitch :: T.Pitch
empty_pitch :: Pitch
empty_pitch = Octave -> CallText -> Pitch
T.Pitch (TrackNum -> Octave
T.Relative TrackNum
0) CallText
""

-- | This note is treated specially by the Check layer, to repeat of the
-- previous note.
dot_note :: T.Note T.CallText (T.NPitch T.Pitch) T.NDuration
dot_note :: Note CallText (NPitch Pitch) NDuration
dot_note = Note Call (NPitch Pitch) NDuration
empty_note
    { note_call :: CallText
T.note_call = CallText
""
    , note_duration :: NDuration
T.note_duration = Duration -> NDuration
T.NDuration forall a b. (a -> b) -> a -> b
$ Duration
empty_duration { dur_dots :: TrackNum
T.dur_dots = TrackNum
1 }
    }

-- | This note is treated specially by the Check layer, to repeat of the
-- previous note, plus put a tie on the previous note.
tie_note :: T.Note T.CallText (T.NPitch T.Pitch) T.NDuration
tie_note :: Note CallText (NPitch Pitch) NDuration
tie_note = Note Call (NPitch Pitch) NDuration
empty_note
    { note_call :: CallText
T.note_call = CallText
""
    , note_duration :: NDuration
T.note_duration = Duration -> NDuration
T.NDuration forall a b. (a -> b) -> a -> b
$ Duration
empty_duration { dur_tie :: Bool
T.dur_tie = Bool
True }
    }

-- |
-- > plain-word
-- > "ns/block"
-- > "word with spaces"
-- > "with embedded "() quote"
-- > [sub // block]
-- > plain-word[sub // block]
-- > "spaces word"[sub]
instance Element T.Call where
    parse :: Config -> ParsecT Void CallText Identity Call
parse Config
config =
        forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CallText -> [Tracks Call] -> Call
T.SubBlock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (Config -> Parser (CallText, [Tracks Call])
p_subblock Config
config)
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CallText -> Call
T.Call forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void CallText Identity CallText
p_string
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CallText -> Call
T.Call forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 Char -> Bool
call_char
        forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"call"
    unparse :: Config -> Call -> CallText
unparse Config
_ (T.Call CallText
call)
        | (Char -> Bool) -> CallText -> Bool
Text.any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
' ', Char
'/']) CallText
call = CallText
"\"" forall a. Semigroup a => a -> a -> a
<> CallText
call forall a. Semigroup a => a -> a -> a
<> CallText
"\""
        | Bool
otherwise = CallText
call
    unparse Config
config (T.SubBlock CallText
prefix [Tracks Call]
tracks) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
        (if CallText -> Bool
Text.null CallText
prefix then CallText
"" else forall a. Element a => Config -> a -> CallText
unparse Config
config (CallText -> Call
T.Call CallText
prefix))
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Element a => Config -> a -> CallText
unparse Config
config) [Tracks Call]
tracks

instance Pretty T.Call where pretty :: Call -> CallText
pretty = forall a. Element a => Config -> a -> CallText
unparse Config
default_config

p_subblock :: Config -> Parser (Text, [T.Tracks T.Call])
p_subblock :: Config -> Parser (CallText, [Tracks Call])
p_subblock Config
config = (,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
lexeme_b (ParsecT Void CallText Identity CallText
p_string forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 Char -> Bool
call_char forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure CallText
"")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some (forall a. Parser a -> Parser a
lexeme_b (forall a. Element a => Config -> Parser a
parse Config
config))

p_string :: Parser Text
p_string :: ParsecT Void CallText Identity CallText
p_string = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
P.between (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'"') (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'"') forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string Tokens CallText
"\"(") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> CallText
Text.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy (forall a. Eq a => a -> a -> Bool
/=Char
'"'))

un_string :: Text -> Text
un_string :: CallText -> CallText
un_string CallText
str = CallText
"\"" forall a. Semigroup a => a -> a -> a
<> CallText
str forall a. Semigroup a => a -> a -> a
<> CallText
"\""

instance Element (T.Rest T.Duration) where
    -- I could possibly forbid ~ tie for rests, but I don't see why
    parse :: Config -> Parser (Rest Duration)
parse Config
config = forall dur. dur -> Rest dur
T.Rest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'_' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Element a => Config -> Parser a
parse Config
config)
    unparse :: Config -> Rest Duration -> CallText
unparse Config
config (T.Rest Duration
dur) = CallText
"_" forall a. Semigroup a => a -> a -> a
<> forall a. Element a => Config -> a -> CallText
unparse Config
config Duration
dur

instance Pretty (T.Rest T.Duration) where
    pretty :: Rest Duration -> CallText
pretty = forall a. Element a => Config -> a -> CallText
unparse Config
default_config

call_char :: Char -> Bool
call_char :: Char -> Bool
call_char = String -> Char -> Bool
not_in
    [ Char
'/'
    , Char
'\\'
    , Char
'['
    , Char
']' -- so a Note inside a SubBlock doesn't eat the ]
    , Char
'>' -- so I can use > to separate tracks when default-call is on
    ]

pitch_char :: Char -> Bool
pitch_char :: Char -> Bool
pitch_char Char
c = String -> Char -> Bool
not_in String
exclude Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
Char.isDigit Char
c)
    where
    -- This breaks modularity because I have to just know all the syntax that
    -- could come after, which is Duration, end of Tracks, Rest.  But the more
    -- I can get into Pitch, the more I can get into Call without needing ""s.
    exclude :: String
exclude =
        [ Char
'~', Char
'.' -- pitch is followed by T.NDuration
        , Char
':' -- T.Duration
        , Char
']' -- end of T.Tracks
        , Char
'*' -- zero duration marker
        , Char
'\\' -- skip whitespace
        , Char
'>' -- this separates tracks
        ]

-- ** Pitch

instance Element T.Pitch where
    parse :: Config -> Parser Pitch
parse Config
config = Octave -> CallText -> Pitch
T.Pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a. Element a => Config -> Parser a
parse Config
config forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 Char -> Bool
pitch_char forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"pitch"
    unparse :: Config -> Pitch -> CallText
unparse Config
config (T.Pitch Octave
octave CallText
call) = forall a. Element a => Config -> a -> CallText
unparse Config
config Octave
octave forall a. Semigroup a => a -> a -> a
<> CallText
call

instance Pretty T.Pitch where pretty :: Pitch -> CallText
pretty = forall a. Element a => Config -> a -> CallText
unparse Config
default_config

instance Element T.Octave where
    parse :: Config -> Parser Octave
parse Config
_ =
        TrackNum -> Octave
T.Absolute forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). ParserT m TrackNum
Parse.p_int forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TrackNum -> Octave
T.Relative forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void CallText Identity TrackNum
p_relative forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"octave"
        where
        p_relative :: ParsecT Void CallText Identity TrackNum
p_relative = forall a. (a -> Char -> a) -> a -> CallText -> a
Text.foldl' (\TrackNum
n Char
c -> TrackNum
n forall a. Num a => a -> a -> a
+ if Char
c forall a. Eq a => a -> a -> Bool
== Char
',' then -TrackNum
1 else TrackNum
1) TrackNum
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
",'" :: String))
    unparse :: Config -> Octave -> CallText
unparse Config
_ (T.Absolute TrackNum
oct) = forall a. Show a => a -> CallText
showt TrackNum
oct
    unparse Config
_ (T.Relative TrackNum
n)
        | TrackNum
n forall a. Ord a => a -> a -> Bool
>= TrackNum
0 = TrackNum -> CallText -> CallText
Text.replicate TrackNum
n CallText
"'"
        | Bool
otherwise = TrackNum -> CallText -> CallText
Text.replicate (-TrackNum
n) CallText
","

instance Pretty T.Octave where pretty :: Octave -> CallText
pretty = forall a. Element a => Config -> a -> CallText
unparse Config
default_config

-- ** Duration

instance Element T.NDuration where
    parse :: Config -> Parser NDuration
parse Config
config =
        forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'0' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure NDuration
T.CallDuration forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Duration -> NDuration
T.NDuration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Element a => Config -> Parser a
parse Config
config
    unparse :: Config -> NDuration -> CallText
unparse Config
config = \case
        NDuration
T.CallDuration -> CallText
"0"
        T.NDuration Duration
a -> forall a. Element a => Config -> a -> CallText
unparse Config
config Duration
a

instance Element T.Duration where
    parse :: Config -> ParsecT Void CallText Identity Duration
parse Config
_ = Maybe TrackNum -> Maybe TrackNum -> TrackNum -> Bool -> Duration
T.Duration
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional forall (m :: * -> *). ParserT m TrackNum
Parse.p_nat
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). ParserT m TrackNum
Parse.p_nat)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CallText -> TrackNum
Text.length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile (forall a. Eq a => a -> a -> Bool
==Char
'.'))
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option Bool
False (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'~' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
        forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"duration"
    unparse :: Config -> Duration -> CallText
unparse Config
_ (T.Duration Maybe TrackNum
int1 Maybe TrackNum
int2 TrackNum
dots Bool
tie) = forall a. Monoid a => [a] -> a
mconcat
        [ forall b a. b -> (a -> b) -> Maybe a -> b
maybe CallText
"" forall a. Show a => a -> CallText
showt Maybe TrackNum
int1
        , forall b a. b -> (a -> b) -> Maybe a -> b
maybe CallText
"" ((CallText
":"<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> CallText
showt) Maybe TrackNum
int2
        , TrackNum -> CallText -> CallText
Text.replicate TrackNum
dots CallText
"."
        , if Bool
tie then CallText
"~" else CallText
""
        ]

-- * util

p_word :: Parser Text
p_word :: ParsecT Void CallText Identity CallText
p_word = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Tokens s)
P.takeWhile1 (String -> Char -> Bool
not_in String
"")

p_whitespace :: Parser ()
p_whitespace :: Parser ()
p_whitespace = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => m a -> m ()
P.skipMany forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
P.space1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
p_comment
    where
    p_comment :: Parser ()
p_comment = do
        forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string Tokens CallText
"--"
        forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m ()
P.skipWhile (forall a. Eq a => a -> a -> Bool
/=Char
'\n')
        forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option () (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'\n')

strip_comment :: Text -> Text
strip_comment :: CallText -> CallText
strip_comment = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => CallText -> CallText -> [CallText]
Text.splitOn CallText
"--"

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = (forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
p_whitespace)

-- | Use a backslash to allow whitespace.  If I had a separate tokenizer, maybe
-- I could implement this as a general-purpose glue together tokens thing, but
-- at least for the moment I only want to do this in a specific spot.
lexeme_b :: Parser a -> Parser a
lexeme_b :: forall a. Parser a -> Parser a
lexeme_b = (forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option () (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
p_whitespace))

keyword :: Text -> Parser ()
keyword :: CallText -> Parser ()
keyword CallText
str = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
lexeme (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string CallText
str)

not_in :: [Char] -> Char -> Bool
not_in :: String -> Char -> Bool
not_in String
cs = \Char
c -> Bool -> Bool
not (Char -> Bool
Char.isSpace Char
c) Bool -> Bool -> Bool
&& Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
cs