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

{-# LANGUAGE CPP #-}
-- | Tracklang parsers.  Many of the parsers in here should be inverses of
-- the 'ShowVal.ShowVal' class.
module Derive.Parse (
    parse_expr
    , parse_val, parse_attrs, parse_num, parse_call
    , lex1, lex, split_pipeline, join_pipeline
    , unparsed_call

    -- * parsers
    , lexeme, p_pipe, p_expr, p_pcontrol, p_identifier, p_symbol
    -- * expand macros
    , expand_macros
    -- * for Parse.Ky
    , p_val
    , p_unparsed_expr, p_null_call, p_single_quote_string
    , p_equal_generic
    , empty_line, spaces
#ifdef TESTING
    , module Derive.Parse
#endif
) where
import           Prelude hiding (lex)
import qualified Control.Applicative as A (many)
import qualified Control.Applicative as Applicative
import qualified Data.Attoparsec.Text as A
import           Data.Attoparsec.Text ((<?>))
import qualified Data.HashMap.Strict as HashMap
import qualified Data.IORef as IORef
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text

import qualified System.IO.Unsafe as Unsafe

import qualified Util.ParseText as ParseText
import qualified Util.Seq as Seq
import qualified Derive.Attrs as Attrs
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Expr as Expr
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Symbols as Symbols

import qualified Perform.Signal as Signal
import qualified Ui.Id as Id

import           Global


{- | Hacky memo table for 'parse_expr'.  There are many small exprs, and
    most of them are the the same, so we can save a lot of parsing time,
    and probably memory too since they will be interned.

    It would be more elegant and probably faster to put the memo directly in
    the Ui.Event, but this would introduce a giant dependency loop from
    low level Ui.Event up to DeriveT.Val.  At the least, it would go
    Ui.Event -> Events.Events -> Ui.State -> Ui.M -> Cmd.M, which means either
    a type parameter would have to propagate that far, or a SOURCE import would
    include that much.
-}
{-# NOINLINE memo_table #-}
memo_table :: IORef.IORef (HashMap Text (Either Text DeriveT.Expr))
memo_table :: IORef (HashMap Text (Either Text Expr))
memo_table = IO (IORef (HashMap Text (Either Text Expr)))
-> IORef (HashMap Text (Either Text Expr))
forall a. IO a -> a
Unsafe.unsafePerformIO (HashMap Text (Either Text Expr)
-> IO (IORef (HashMap Text (Either Text Expr)))
forall a. a -> IO (IORef a)
IORef.newIORef HashMap Text (Either Text Expr)
forall a. Monoid a => a
mempty)

parse_expr :: Text -> Either Text DeriveT.Expr
parse_expr :: Text -> Either Text Expr
parse_expr Text
str
    -- micro-optimize, but probably irrelevant
    | Text -> Bool
Text.null Text
str = Expr -> Either Text Expr
forall a b. b -> Either a b
Right (Expr -> Either Text Expr) -> Expr -> Either Text Expr
forall a b. (a -> b) -> a -> b
$ Symbol -> Call Val
forall val. Symbol -> Call val
Expr.call0 Symbol
"" Call Val -> [Call Val] -> Expr
forall a. a -> [a] -> NonEmpty a
:| []
    | Bool
otherwise = case Text -> HashMap Text (Either Text Expr) -> Maybe (Either Text Expr)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
str HashMap Text (Either Text Expr)
table of
        Just Either Text Expr
expr -> Either Text Expr
expr
        Maybe (Either Text Expr)
Nothing -> (HashMap Text (Either Text Expr)
 -> HashMap Text (Either Text Expr))
-> ()
write (Text
-> Either Text Expr
-> HashMap Text (Either Text Expr)
-> HashMap Text (Either Text Expr)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Text
str Either Text Expr
expr) () -> Either Text Expr -> Either Text Expr
`seq` Either Text Expr
expr
            where expr :: Either Text Expr
expr = Text -> Either Text Expr
parse_expr_raw Text
str
    where
    -- With concurrent access this can duplicate work, but since it's a cache
    -- that should be fine.  Also I don't do a strict modify, it probably makes
    -- no difference but the theory is to spend minimal time adding the entry,
    -- and the next call will force the thunk.
    table :: HashMap Text (Either Text Expr)
table = IO (HashMap Text (Either Text Expr))
-> HashMap Text (Either Text Expr)
forall a. IO a -> a
Unsafe.unsafePerformIO (IO (HashMap Text (Either Text Expr))
 -> HashMap Text (Either Text Expr))
-> IO (HashMap Text (Either Text Expr))
-> HashMap Text (Either Text Expr)
forall a b. (a -> b) -> a -> b
$ IORef (HashMap Text (Either Text Expr))
-> IO (HashMap Text (Either Text Expr))
forall a. IORef a -> IO a
IORef.readIORef IORef (HashMap Text (Either Text Expr))
memo_table
    write :: (HashMap Text (Either Text Expr)
 -> HashMap Text (Either Text Expr))
-> ()
write = IO () -> ()
forall a. IO a -> a
Unsafe.unsafePerformIO (IO () -> ())
-> ((HashMap Text (Either Text Expr)
     -> HashMap Text (Either Text Expr))
    -> IO ())
-> (HashMap Text (Either Text Expr)
    -> HashMap Text (Either Text Expr))
-> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (HashMap Text (Either Text Expr))
-> (HashMap Text (Either Text Expr)
    -> HashMap Text (Either Text Expr))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef IORef (HashMap Text (Either Text Expr))
memo_table

{-# SCC parse_expr_raw #-}
parse_expr_raw :: Text -> Either Text DeriveT.Expr
parse_expr_raw :: Text -> Either Text Expr
parse_expr_raw = Parser Expr -> Text -> Either Text Expr
forall a. Parser a -> Text -> Either Text a
parse (Bool -> Parser Expr
p_expr Bool
True)

-- | Parse a single Val.
{-# SCC parse_val #-}
parse_val :: Text -> Either Text DeriveT.Val
parse_val :: Text -> Either Text Val
parse_val = Parser Val -> Text -> Either Text Val
forall a. Parser a -> Text -> Either Text a
ParseText.parse1 (Parser Val -> Parser Val
forall a. Parser a -> Parser a
lexeme Parser Val
p_val)

-- | Parse attributes in the form +a+b.
parse_attrs :: String -> Either Text Attrs.Attributes
parse_attrs :: String -> Either Text Attributes
parse_attrs = Parser Attributes -> Text -> Either Text Attributes
forall a. Parser a -> Text -> Either Text a
parse Parser Attributes
p_attributes (Text -> Either Text Attributes)
-> (String -> Text) -> String -> Either Text Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

-- | Parse a number or hex code, without a type suffix.
parse_num :: Text -> Either Text Signal.Y
parse_num :: Text -> Either Text Y
parse_num = Parser Y -> Text -> Either Text Y
forall a. Parser a -> Text -> Either Text a
ParseText.parse1 (Parser Y -> Parser Y
forall a. Parser a -> Parser a
lexeme (Parser Y
p_hex Parser Y -> Parser Y -> Parser Y
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Y
p_untyped_num))

-- | Extract only the call part of the text.
parse_call :: Text -> Maybe Text
parse_call :: Text -> Maybe Text
parse_call Text
text = case Text -> Either Text Expr
parse_expr_raw Text
text of
    Right Expr
expr -> case Expr -> Call Val
forall a. NonEmpty a -> a
NonEmpty.last Expr
expr of
        Expr.Call (Expr.Symbol Text
call) [Term Val]
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
call
    Either Text Expr
_ -> Maybe Text
forall a. Maybe a
Nothing

parse :: A.Parser a -> Text -> Either Text a
parse :: forall a. Parser a -> Text -> Either Text a
parse Parser a
p = Parser a -> Text -> Either Text a
forall a. Parser a -> Text -> Either Text a
ParseText.parse1 (Parser ()
spaces Parser () -> Parser a -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser a
p)

-- * lex

-- | Lex out a single expression.  This isn't really a traditional lex, because
-- it will extract a whole parenthesized expression instead of a token.  Also,
-- this leaves on trailing whitespace, so you can concatenate the lexed out
-- words and get the original input back.
lex1 :: Text -> (Text, Text)
lex1 :: Text -> (Text, Text)
lex1 Text
text = case Parser ((), Text) -> Text -> Either Text ((), Text)
forall a. Parser a -> Text -> Either Text a
parse ((,) (() -> Text -> ((), Text))
-> Parser () -> Parser Text (Text -> ((), Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ()
p_lex1 Parser Text (Text -> ((), Text))
-> Parser Text -> Parser ((), Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> Parser Text
A.takeWhile (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)) Text
text of
    Right ((), Text
rest) ->
        (Int -> Text -> Text
Text.take (Text -> Int
Text.length Text
text Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
rest) Text
text, Text
rest)
    Left Text
_ -> (Text
text, Text
"")

-- | Like 'lex1', but get all of them.
lex :: Text -> [Text]
lex :: Text -> [Text]
lex Text
text
    | Text -> Bool
Text.null Text
pre = []
    | Text -> Bool
Text.null Text
post = [Text
pre]
    | Bool
otherwise = Text
pre Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text -> [Text]
lex Text
post
    where
    (Text
pre, Text
post) = Text -> (Text, Text)
lex1 Text
text

-- | Take an expression and lex it into words, where each sublist corresponds
-- to one expression in the pipeline.  Like 'lex1', this corresponds to call
-- name and arguments, not tokens.  The final word could be a comment.
--
-- This preserves trailing spaces on the words, because track editors use that
-- to infer edits in progress.
split_pipeline :: Text -> [[Text]]
split_pipeline :: Text -> [[Text]]
split_pipeline =
    ([Text] -> [Text]) -> [[Text]] -> [[Text]]
forall a. (a -> a) -> [a] -> [a]
Seq.map_tail (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1) ([[Text]] -> [[Text]]) -> (Text -> [[Text]]) -> Text -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [[Text]]
forall a. (a -> Bool) -> [a] -> [[a]]
Seq.split_before ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
"|") (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip) ([Text] -> [[Text]]) -> (Text -> [Text]) -> Text -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
lex

join_pipeline :: [[Text]] -> Text
join_pipeline :: [[Text]] -> Text
join_pipeline =
    [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([[Text]] -> [Text]) -> [[Text]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [[Text]] -> [Text]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Text
" | "] ([[Text]] -> [Text])
-> ([[Text]] -> [[Text]]) -> [[Text]] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> [Text]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text) -> [Text] -> [Text]
forall a. (a -> a) -> [a] -> [a]
Seq.map_last Text -> Text
Text.stripEnd)

-- | This returns () on success and the caller will see how many chars were
-- consumed.  Attoparsec doesn't keep track of byte position, and always
-- backtracks.  I think this means I can't reuse 'p_term'.
p_lex1 :: A.Parser ()
p_lex1 :: Parser ()
p_lex1 =
    (Parser ()
str Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
parens Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser (Maybe Char)
p_equal_operator Parser (Maybe Char) -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
unparsed Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
comment
            Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
word)
        Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((Char -> Bool) -> Parser ()
A.skipWhile Char -> Bool
is_whitespace)
    where
    str :: Parser ()
str = Parser Text
p_single_quote_string Parser Text -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    parens :: Parser ()
parens = do
        Char -> Parser Char
A.char Char
'('
        Parser () -> Parser Text [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many (Parser () -> Parser Text [()]) -> Parser () -> Parser Text [()]
forall a b. (a -> b) -> a -> b
$ Parser ()
parens Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
str Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Char -> Bool) -> Parser Text
A.takeWhile1 Char -> Bool
content_char Parser Text -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        Char -> Parser Char
A.char Char
')'
        () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    word :: Parser ()
word = (Char -> Bool) -> Parser ()
A.skipWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(' Bool -> Bool -> Bool
&& Char -> Bool
is_word_char Char
c)
    content_char :: Char -> Bool
content_char Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\''
    unparsed :: Parser ()
unparsed = Text -> Parser Text
A.string (Symbol -> Text
Expr.unsym Symbol
unparsed_call)
        Parser Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ()
A.skipWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'|' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')')
    comment :: Parser ()
comment = Text -> Parser Text
A.string Text
"--" Parser Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ()
A.skipWhile (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)

-- * expand macros

-- | Map the identifiers after a \"\@\" through the given function.  Used
-- to implement ID macros for the REPL.
--
-- A macro looks like \@valid-id-chars.
expand_macros :: (Text -> Text) -> Text -> Either Text Text
expand_macros :: (Text -> Text) -> Text -> Either Text Text
expand_macros Text -> Text
replacement Text
text
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
"@" Text -> Text -> Bool
`Text.isInfixOf` Text
text = Text -> Either Text Text
forall a b. b -> Either a b
Right Text
text
    | Bool
otherwise = Parser Text -> Text -> Either Text Text
forall a. Parser a -> Text -> Either Text a
ParseText.parse1 ((Text -> Text) -> Parser Text
p_macros Text -> Text
replacement) Text
text

p_macros :: (Text -> Text) -> A.Parser Text
p_macros :: (Text -> Text) -> Parser Text
p_macros Text -> Text
replace = do
    [Text]
chunks <- Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 (Parser Text -> Parser Text [Text])
-> Parser Text -> Parser Text [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> Parser Text
p_macro Text -> Text
replace Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
p_chunk
        Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Text
"\""<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
"\"") (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
p_hs_string)
    Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
chunks
    where
    p_chunk :: Parser Text
p_chunk = (Char -> Bool) -> Parser Text
A.takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@')

p_macro :: (Text -> Text) -> A.Parser Text
p_macro :: (Text -> Text) -> Parser Text
p_macro Text -> Text
replacement = do
    Char -> Parser Char
A.char Char
'@'
    Text -> Text
replacement (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Text
unbackslash (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
bare_string)
    where
    -- Strip escaped quotes, because 'show' will turn it back into haskell
    -- and re-add them.  This will mess up all the other zillion backslash
    -- features in haskell strings, but I probably won't use those.  'p_str'
    -- would be simpler, but since it's for the REPL, I feel like haskell-ish
    -- strings will be less error-prone.
    unbackslash :: Text -> Text
unbackslash = String -> Text
txt (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
strip (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
untxt
        where
        strip :: String -> String
strip (Char
'\\':Char
c:String
cs) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
strip String
cs
        strip (Char
c:String
cs) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
strip String
cs
        strip [] = []
    bare_string :: Parser Text
bare_string = (Char -> Bool) -> Parser Text
A.takeWhile1 (\Char
c -> Char -> Bool
Id.is_id_char Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')

p_hs_string :: A.Parser Text
p_hs_string :: Parser Text
p_hs_string =
    Parser Char -> Parser Char -> Parser Text -> Parser Text
forall x y a. Parser x -> Parser y -> Parser a -> Parser a
ParseText.between (Char -> Parser Char
A.char Char
'"') (Char -> Parser Char
A.char Char
'"') (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> Parser Text [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many Parser Text
chunk
    where
    chunk :: Parser Text
chunk = (Char -> Parser Char
A.char Char
'\\' Parser Char -> Parser Text -> Parser Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Text -> Text
Text.cons Char
'\\' (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser Text
A.take Int
1)
        Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Parser Text
A.takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\')

-- * toplevel parsers

p_expr :: Bool -> A.Parser DeriveT.Expr
p_expr :: Bool -> Parser Expr
p_expr Bool
toplevel = do
    -- It definitely matches at least one, because p_null_call always matches.
    Call Val
c : [Call Val]
cs <- Parser Text (Call Val) -> Parser () -> Parser Text [Call Val]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
A.sepBy1 (Bool -> Parser Text (Call Val)
p_toplevel_call Bool
toplevel) Parser ()
p_pipe
    Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Call Val
c Call Val -> [Call Val] -> Expr
forall a. a -> [a] -> NonEmpty a
:| [Call Val]
cs

-- | A toplevel call has a few special syntactic forms, other than the plain
-- @call arg arg ...@ form parsed by 'p_call'.
p_toplevel_call :: Bool -> A.Parser DeriveT.Call
p_toplevel_call :: Bool -> Parser Text (Call Val)
p_toplevel_call Bool
toplevel =
    Parser Text (Call Val)
p_unparsed_expr Parser Text (Call Val)
-> Parser Text (Call Val) -> Parser Text (Call Val)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text (Call Val)
p_equal Parser Text (Call Val)
-> Parser Text (Call Val) -> Parser Text (Call Val)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Text (Call Val)
p_call Bool
toplevel Parser Text (Call Val)
-> Parser Text (Call Val) -> Parser Text (Call Val)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text (Call Val)
forall a. Parser (Call a)
p_null_call

-- | Parse a 'unparsed_call'.
p_unparsed_expr :: A.Parser DeriveT.Call
p_unparsed_expr :: Parser Text (Call Val)
p_unparsed_expr = do
    Text -> Parser Text
A.string (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Symbol -> Text
Expr.unsym Symbol
unparsed_call
    Text
text <- (Char -> Bool) -> Parser Text
A.takeWhile ((Char -> Bool) -> Parser Text) -> (Char -> Bool) -> Parser Text
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'|' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')'
    let arg :: Str
arg = Text -> Str
Expr.Str (Text -> Str) -> Text -> Str
forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
strip_comment Text
text
    Call Val -> Parser Text (Call Val)
forall (m :: * -> *) a. Monad m => a -> m a
return (Call Val -> Parser Text (Call Val))
-> Call Val -> Parser Text (Call Val)
forall a b. (a -> b) -> a -> b
$ Symbol -> [Term Val] -> Call Val
forall val. Symbol -> [Term val] -> Call val
Expr.Call Symbol
unparsed_call [Val -> Term Val
forall val. val -> Term val
Expr.Literal (Val -> Term Val) -> Val -> Term Val
forall a b. (a -> b) -> a -> b
$ Str -> Val
DeriveT.VStr Str
arg]
    where
    -- Normally comments are considered whitespace by 'spaces_to_eol'.  Normal
    -- tokenization is suppressed for 'unparsed_call' so that doesn't happen,
    -- but I still want to allow comments, for consistency.
    strip_comment :: Text -> Text
strip_comment = (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> (Text -> (Text, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> (Text, Text)
Text.breakOn Text
"--"

-- | This is a magic call name that suppresses normal parsing.  Instead, the
-- rest of the event expression is passed as a string.  The only characters
-- that can't be used are ) and |, so an unparsed call can still be included in
-- a sub expression.
unparsed_call :: Expr.Symbol
unparsed_call :: Symbol
unparsed_call = Symbol
"!"

p_pipe :: A.Parser ()
p_pipe :: Parser ()
p_pipe = Parser Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Char -> Parser ()) -> Parser Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser Char -> Parser Char
forall a. Parser a -> Parser a
lexeme (Char -> Parser Char
A.char Char
'|')

p_equal :: A.Parser (Expr.Call DeriveT.Val)
p_equal :: Parser Text (Call Val)
p_equal = do
    (Str
lhs, Maybe Str
sym, [Term Val]
rhs) <- Parser (Term Val) -> Parser (Str, Maybe Str, [Term Val])
forall a. Parser a -> Parser (Str, Maybe Str, [a])
p_equal_generic (Parser (Term Val) -> Parser (Term Val)
forall a. Parser a -> Parser a
lexeme Parser (Term Val)
p_term)
    Call Val -> Parser Text (Call Val)
forall (m :: * -> *) a. Monad m => a -> m a
return (Call Val -> Parser Text (Call Val))
-> Call Val -> Parser Text (Call Val)
forall a b. (a -> b) -> a -> b
$ Symbol -> [Term Val] -> Call Val
forall val. Symbol -> [Term val] -> Call val
Expr.Call Symbol
Symbols.equal ([Term Val] -> Call Val) -> [Term Val] -> Call Val
forall a b. (a -> b) -> a -> b
$
        Str -> Term Val
literal Str
lhs Term Val -> [Term Val] -> [Term Val]
forall a. a -> [a] -> [a]
: [Term Val]
rhs [Term Val] -> [Term Val] -> [Term Val]
forall a. [a] -> [a] -> [a]
++ [Term Val]
-> (Term Val -> [Term Val]) -> Maybe (Term Val) -> [Term Val]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Term Val -> [Term Val] -> [Term Val]
forall a. a -> [a] -> [a]
:[]) (Str -> Term Val
literal (Str -> Term Val) -> Maybe Str -> Maybe (Term Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Str
sym)
    where literal :: Str -> Term Val
literal = Val -> Term Val
forall val. val -> Term val
Expr.Literal (Val -> Term Val) -> (Str -> Val) -> Str -> Term Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> Val
DeriveT.VStr

p_equal_generic :: A.Parser a -> A.Parser (Expr.Str, Maybe Expr.Str, [a])
p_equal_generic :: forall a. Parser a -> Parser (Str, Maybe Str, [a])
p_equal_generic Parser a
rhs_term = do
    Text
lhs <- (Str -> Text
Expr.unstr (Str -> Text) -> Parser Text Str -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Str
p_str) Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Symbol -> Text
Expr.unsym (Symbol -> Text) -> Parser Text Symbol -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Parser Text Symbol
p_symbol Bool
True)
    Parser ()
spaces
    Maybe Char
mb_sym <- Parser (Maybe Char)
p_equal_operator
    Parser ()
spaces
    [a]
rhs <- Parser a -> Parser Text [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 Parser a
rhs_term
    (Str, Maybe Str, [a]) -> Parser (Str, Maybe Str, [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Str
Expr.Str Text
lhs, Text -> Str
Expr.Str (Text -> Str) -> (Char -> Text) -> Char -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
Text.singleton (Char -> Str) -> Maybe Char -> Maybe Str
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Char
mb_sym, [a]
rhs)

p_equal_operator :: A.Parser (Maybe Char)
p_equal_operator :: Parser (Maybe Char)
p_equal_operator = Char -> Parser Char
A.char Char
'=' Parser Char -> Parser (Maybe Char) -> Parser (Maybe Char)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char -> Parser (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ((Char -> Bool) -> Parser Char
A.satisfy (String -> Char -> Bool
A.inClass String
merge_symbols))

-- | Valid symbols after =.  This should correspond to the keys in
-- Equal.symbol_to_merge.  It could have more symbols, but then that syntax
-- becomes unavailable.  E.g. previously % was in the list, but then
-- @x=%control@ has to be written @x = %control@.
merge_symbols :: [Char]
merge_symbols :: String
merge_symbols = String
"-+*@"

p_call :: Bool -> A.Parser (Expr.Call DeriveT.Val)
p_call :: Bool -> Parser Text (Call Val)
p_call Bool
toplevel = Symbol -> [Term Val] -> Call Val
forall val. Symbol -> [Term val] -> Call val
Expr.Call
    (Symbol -> [Term Val] -> Call Val)
-> Parser Text Symbol -> Parser Text ([Term Val] -> Call Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Symbol -> Parser Text Symbol
forall a. Parser a -> Parser a
lexeme (Bool -> Parser Text Symbol
p_symbol Bool
toplevel)
    Parser Text ([Term Val] -> Call Val)
-> Parser Text [Term Val] -> Parser Text (Call Val)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text [Term Val] -> Parser Text [Term Val]
forall a. Parser a -> Parser a
lexeme (Parser (Term Val) -> Parser () -> Parser Text [Term Val]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
A.sepBy Parser (Term Val)
p_term Parser ()
spaces1)

p_null_call :: A.Parser (Expr.Call a)
p_null_call :: forall a. Parser (Call a)
p_null_call = Call a -> Parser Text (Call a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol -> [Term a] -> Call a
forall val. Symbol -> [Term val] -> Call val
Expr.Call Symbol
"" []) Parser Text (Call a) -> String -> Parser Text (Call a)
forall i a. Parser i a -> String -> Parser i a
<?> String
"null call"

-- | Any word in call position is considered a Str.  This means that
-- you can have calls like @4@ and @>@, which are useful names for notes or
-- ornaments.
p_symbol :: Bool -- ^ A call at the top level can allow a ).
    -> A.Parser Expr.Symbol
p_symbol :: Bool -> Parser Text Symbol
p_symbol Bool
toplevel = Text -> Symbol
Expr.Symbol (Text -> Symbol) -> Parser Text -> Parser Text Symbol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Parser Text
p_word Bool
toplevel

p_term :: A.Parser (Expr.Term DeriveT.Val)
p_term :: Parser (Term Val)
p_term = Val -> Term Val
forall val. val -> Term val
Expr.Literal (Val -> Term Val) -> Parser Val -> Parser (Term Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Val
p_val Parser (Term Val) -> Parser (Term Val) -> Parser (Term Val)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Call Val -> Term Val
forall val. Call val -> Term val
Expr.ValCall (Call Val -> Term Val)
-> Parser Text (Call Val) -> Parser (Term Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Call Val)
p_sub_call
    Parser (Term Val) -> String -> Parser (Term Val)
forall i a. Parser i a -> String -> Parser i a
<?> String
"term"

p_sub_call :: A.Parser (Expr.Call DeriveT.Val)
p_sub_call :: Parser Text (Call Val)
p_sub_call = Parser Char
-> Parser Char -> Parser Text (Call Val) -> Parser Text (Call Val)
forall x y a. Parser x -> Parser y -> Parser a -> Parser a
ParseText.between (Char -> Parser Char
A.char Char
'(') (Char -> Parser Char
A.char Char
')') (Bool -> Parser Text (Call Val)
p_call Bool
False)

p_val :: A.Parser DeriveT.Val
p_val :: Parser Val
p_val =
    Attributes -> Val
DeriveT.VAttributes (Attributes -> Val) -> Parser Attributes -> Parser Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Attributes
p_attributes
    Parser Val -> Parser Val -> Parser Val
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Typed Y -> Val
DeriveT.VNum (Typed Y -> Val) -> (Y -> Typed Y) -> Y -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Typed Y
forall a. a -> Typed a
ScoreT.untyped (Y -> Val) -> Parser Y -> Parser Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Y
p_hex
    Parser Val -> Parser Val -> Parser Val
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Typed Y -> Val
DeriveT.VNum (Typed Y -> Val) -> Parser Text (Typed Y) -> Parser Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text (Typed Y)
p_num
    Parser Val -> Parser Val -> Parser Val
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Str -> Val
DeriveT.VStr (Str -> Val) -> Parser Text Str -> Parser Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Str
p_str
    Parser Val -> Parser Val -> Parser Val
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ControlRef -> Val
DeriveT.VControlRef (ControlRef -> Val) -> Parser Text ControlRef -> Parser Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text ControlRef
p_control_ref
    Parser Val -> Parser Val -> Parser Val
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PControlRef -> Val
DeriveT.VPControlRef (PControlRef -> Val)
-> (PControl -> PControlRef) -> PControl -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PControl -> PControlRef
forall control val. control -> Ref control val
DeriveT.LiteralControl (PControl -> Val) -> Parser Text PControl -> Parser Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text PControl
p_pcontrol
    Parser Val -> Parser Val -> Parser Val
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Quoted -> Val
DeriveT.VQuoted (Quoted -> Val) -> Parser Text Quoted -> Parser Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Quoted
p_quoted
    Parser Val -> Parser Val -> Parser Val
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
A.char Char
'_' Parser Char -> Parser Val -> Parser Val
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Val -> Parser Val
forall (m :: * -> *) a. Monad m => a -> m a
return Val
DeriveT.VNotGiven)
    Parser Val -> Parser Val -> Parser Val
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
A.char Char
';' Parser Char -> Parser Val -> Parser Val
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Val -> Parser Val
forall (m :: * -> *) a. Monad m => a -> m a
return Val
DeriveT.VSeparator)
    Parser Val -> Parser Val -> Parser Val
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Str -> Val
DeriveT.VStr (Str -> Val) -> Parser Text Str -> Parser Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Str
p_unquoted_str

p_num :: A.Parser (ScoreT.Typed Signal.Y)
p_num :: Parser Text (Typed Y)
p_num = do
    Y
num <- Parser Y
p_untyped_num
    let suffix :: (b, Text) -> Parser Text b
suffix (b
typ, Text
suf) = Text -> Parser Text
A.string Text
suf Parser Text -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Parser Text b
forall (m :: * -> *) a. Monad m => a -> m a
return b
typ
    Type
typ <- [Parser Text Type] -> Parser Text Type
forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice ([Parser Text Type] -> Parser Text Type)
-> [Parser Text Type] -> Parser Text Type
forall a b. (a -> b) -> a -> b
$ ((Type, Text) -> Parser Text Type)
-> [(Type, Text)] -> [Parser Text Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Text) -> Parser Text Type
forall {b}. (b, Text) -> Parser Text b
suffix [(Type, Text)]
codes
    Typed Y -> Parser Text (Typed Y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed Y -> Parser Text (Typed Y))
-> Typed Y -> Parser Text (Typed Y)
forall a b. (a -> b) -> a -> b
$ Type -> Y -> Typed Y
forall a. Type -> a -> Typed a
ScoreT.Typed Type
typ Y
num
    where
    codes :: [(Type, Text)]
codes = [Type] -> [Text] -> [(Type, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
ScoreT.all_types ([Text] -> [(Type, Text)]) -> [Text] -> [(Type, Text)]
forall a b. (a -> b) -> a -> b
$ (Type -> Text) -> [Type] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Text
ScoreT.type_to_code [Type]
ScoreT.all_types

p_untyped_num :: A.Parser Signal.Y
p_untyped_num :: Parser Y
p_untyped_num = Parser Y
p_ratio Parser Y -> Parser Y -> Parser Y
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Y
ParseText.p_float
    -- It may seem as if this should include p_hex, but I don't want it
    -- for p_num, because none of the type codes make sense for a 0-1
    -- normalized value.

p_ratio :: A.Parser Signal.Y
p_ratio :: Parser Y
p_ratio = do
    Char
sign <- Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Char
'+' ((Char -> Bool) -> Parser Char
A.satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'))
    Int
num <- Parser Int
ParseText.p_nat
    Char -> Parser Char
A.char Char
'/'
    Int
denom <- Parser Int
ParseText.p_nat
    Y -> Parser Y
forall (m :: * -> *) a. Monad m => a -> m a
return (Y -> Parser Y) -> Y -> Parser Y
forall a b. (a -> b) -> a -> b
$ (if Char
sign Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' then -Y
1 else Y
1)
        Y -> Y -> Y
forall a. Num a => a -> a -> a
* Int -> Y
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/ Int -> Y
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
denom

-- | Parse numbers of the form @`0x`00@ or @0x00@, with an optional @-@ prefix
-- for negation.
p_hex :: A.Parser Signal.Y
p_hex :: Parser Y
p_hex = do
    Y
sign <- Y -> Parser Y -> Parser Y
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Y
1 (Char -> Parser Char
A.char Char
'-' Parser Char -> Parser Y -> Parser Y
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Y -> Parser Y
forall (m :: * -> *) a. Monad m => a -> m a
return (-Y
1))
    Text -> Parser Text
A.string Text
ShowVal.hex_prefix Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
A.string Text
"0x"
    let higit :: Char -> Bool
higit Char
c = Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' Bool -> Bool -> Bool
|| Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f'
    Char
c1 <- (Char -> Bool) -> Parser Char
A.satisfy Char -> Bool
higit
    Char
c2 <- (Char -> Bool) -> Parser Char
A.satisfy Char -> Bool
higit
    Y -> Parser Y
forall (m :: * -> *) a. Monad m => a -> m a
return (Y -> Parser Y) -> Y -> Parser Y
forall a b. (a -> b) -> a -> b
$ Int -> Y
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Char -> Int
parse_hex Char
c1 Char
c2) Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/ Y
0xff Y -> Y -> Y
forall a. Num a => a -> a -> a
* Y
sign

parse_hex :: Char -> Char -> Int
parse_hex :: Char -> Char -> Int
parse_hex Char
c1 Char
c2 = Char -> Int
higit Char
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
higit Char
c2
    where
    higit :: Char -> Int
higit Char
c
        | Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'0'
        | Bool
otherwise = Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10

-- | A string is anything between single quotes.  A single quote itself is
-- represented by two single quotes in a row.
p_str :: A.Parser Expr.Str
p_str :: Parser Text Str
p_str = Text -> Str
Expr.Str (Text -> Str) -> Parser Text -> Parser Text Str
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
p_single_quote_string

p_single_quote_string :: A.Parser Text
p_single_quote_string :: Parser Text
p_single_quote_string = do
    [Text]
chunks <- Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 (Parser Text -> Parser Text [Text])
-> Parser Text -> Parser Text [Text]
forall a b. (a -> b) -> a -> b
$
        Parser Char -> Parser Char -> Parser Text -> Parser Text
forall x y a. Parser x -> Parser y -> Parser a -> Parser a
ParseText.between (Char -> Parser Char
A.char Char
'\'') (Char -> Parser Char
A.char Char
'\'') ((Char -> Bool) -> Parser Text
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\''))
    Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
"'" [Text]
chunks

-- There's no particular reason to restrict attrs to idents, but this will
-- force some standardization on the names.
p_attributes :: A.Parser Attrs.Attributes
p_attributes :: Parser Attributes
p_attributes = Char -> Parser Char
A.char Char
'+'
    Parser Char -> Parser Attributes -> Parser Attributes
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Text] -> Attributes
Attrs.attrs ([Text] -> Attributes) -> Parser Text [Text] -> Parser Attributes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser Char -> Parser Text [Text]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
A.sepBy (Bool -> String -> Parser Text
p_identifier Bool
False String
"+") (Char -> Parser Char
A.char Char
'+'))

p_control_ref :: A.Parser DeriveT.ControlRef
p_control_ref :: Parser Text ControlRef
p_control_ref = do
    Char -> Parser Char
A.char Char
'%'
    Control
control <- Text -> Control
ScoreT.unchecked_control (Text -> Control) -> Parser Text -> Parser Text Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Text
"" (Bool -> String -> Parser Text
p_identifier Bool
False String
",")
    Maybe (Typed Y)
deflt <- Parser Text (Typed Y) -> Parser (Maybe (Typed Y))
forall a. Parser a -> Parser (Maybe a)
ParseText.optional (Char -> Parser Char
A.char Char
',' Parser Char -> Parser Text (Typed Y) -> Parser Text (Typed Y)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text (Typed Y)
p_num)
    ControlRef -> Parser Text ControlRef
forall (m :: * -> *) a. Monad m => a -> m a
return (ControlRef -> Parser Text ControlRef)
-> ControlRef -> Parser Text ControlRef
forall a b. (a -> b) -> a -> b
$ case Maybe (Typed Y)
deflt of
        Maybe (Typed Y)
Nothing -> Control -> ControlRef
forall control val. control -> Ref control val
DeriveT.LiteralControl Control
control
        Just Typed Y
val -> Control -> Typed Control -> ControlRef
forall control val. control -> val -> Ref control val
DeriveT.DefaultedControl Control
control (Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant (Y -> Control) -> Typed Y -> Typed Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Y
val)
    Parser Text ControlRef -> String -> Parser Text ControlRef
forall i a. Parser i a -> String -> Parser i a
<?> String
"control"

-- | Unlike 'p_control_ref', this doesn't parse a comma and a default value,
-- because pitches don't have literals.  Instead, use the @pitch-control@ val
-- call.
p_pcontrol :: A.Parser ScoreT.PControl
p_pcontrol :: Parser Text PControl
p_pcontrol = do
    Char -> Parser Char
A.char Char
'#'
    Text -> PControl
ScoreT.unchecked_pcontrol (Text -> PControl) -> Parser Text -> Parser Text PControl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> Parser Text
p_identifier Bool
True String
""
    Parser Text PControl -> String -> Parser Text PControl
forall i a. Parser i a -> String -> Parser i a
<?> String
"pitch control"

p_quoted :: A.Parser DeriveT.Quoted
p_quoted :: Parser Text Quoted
p_quoted = Parser Text
-> Parser Text -> Parser Text Quoted -> Parser Text Quoted
forall x y a. Parser x -> Parser y -> Parser a -> Parser a
ParseText.between Parser Text
"\"(" Parser Text
")" (Expr -> Quoted
DeriveT.Quoted (Expr -> Quoted) -> Parser Expr -> Parser Text Quoted
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Parser Expr
p_expr Bool
False)

-- | Symbols can have anything in them but they have to start with a letter.
-- This means special literals can start with wacky characters and not be
-- ambiguous.
--
-- This should be a superset of what 'p_identifier' will accept, so if IDs use
-- 'p_identifier' and 'Id.valid_symbol', they will also be parseable without
-- quotes.
p_unquoted_str :: A.Parser Expr.Str
p_unquoted_str :: Parser Text Str
p_unquoted_str = do
    Text
sym <- Char -> Text -> Text
Text.cons
        (Char -> Text -> Text) -> Parser Char -> Parser Text (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Char
A.satisfy Char -> Bool
ShowVal.is_unquoted_head
        Parser Text (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> Parser Text
A.takeWhile Char -> Bool
is_word_char
    -- If I have an unbalanced quote, it may parse as an unquoted string with
    -- a quote in it, which is confusing.  So let's outlaw that.
    Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
"'" Text -> Text -> Bool
`Text.isInfixOf` Text
sym) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
        String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"quote in unquoted string: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
sym
    Str -> Parser Text Str
forall (m :: * -> *) a. Monad m => a -> m a
return (Str -> Parser Text Str) -> Str -> Parser Text Str
forall a b. (a -> b) -> a -> b
$ Text -> Str
Expr.Str Text
sym

-- | Identifiers are somewhat more strict than usual.  They must be lowercase,
-- and the only non-letter allowed is hyphen.  This means words must be
-- separated with hyphens, and leaves me free to give special meanings to
-- underscores or caps if I want.
--
-- @until@ gives additional chars that stop parsing, for idents that are
-- embedded in another lexeme.
p_identifier :: Bool -> String -> A.Parser Text
p_identifier :: Bool -> String -> Parser Text
p_identifier Bool
null_ok String
until = do
    -- TODO attoparsec docs say it's faster to do the check manually, profile
    -- and see if it makes a difference.
    Text
ident <- (if Bool
null_ok then (Char -> Bool) -> Parser Text
A.takeWhile else (Char -> Bool) -> Parser Text
A.takeWhile1)
        -- (A.notInClass (until ++ " \n\t|=)")) -- buggy?
        (\Char
c -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
until Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'
            Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'|' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')')
        -- Newlines and tabs are forbidden from track and block titles and
        -- events, but can occur in ky files.
    -- This forces identifiers to be separated with spaces, except with | and
    -- =.  Otherwise @sym>inst@ is parsed as a call @sym >inst@, which I don't
    -- want to support.
    Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Bool
null_ok Bool -> Bool -> Bool
&& Text -> Bool
Text.null Text
ident) Bool -> Bool -> Bool
|| Text -> Bool
Id.valid_symbol Text
ident) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
        String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"invalid chars in identifier, expected "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
untxt Text
Id.symbol_description String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
ident
    Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
ident

p_word :: Bool -> A.Parser Text
p_word :: Bool -> Parser Text
p_word Bool
toplevel =
    (Char -> Bool) -> Parser Text
A.takeWhile1 (if Bool
toplevel then Char -> Bool
is_toplevel_word_char else Char -> Bool
is_word_char)

-- | A word is as permissive as possible, and is terminated by whitespace.
-- That's because this determines how calls are allowed to be named, and for
-- expressiveness it's nice to use symbols.  For example, the slur call is just
-- @(@.
--
-- At the toplevel, any character is allowed except @=@, which lets me write
-- 'p_equal' expressions without spaces.  In sub calls, @)@ is not allowed,
-- because then I couldn't tell where the sub call expression ends, e.g. @())@.
-- However, @(()@ is fine, even though it looks weird.
--
-- I could get rid of the toplevel distinction by not allowing ) in calls
-- even at the toplevel, but I have @ly-(@ and @ly-)@ calls and I kind of like
-- how those look.  I guess it's a crummy justification, but no need to change
-- it unless toplevel gives more more trouble.
is_toplevel_word_char :: Char -> Bool
is_toplevel_word_char :: Char -> Bool
is_toplevel_word_char Char
c = Char -> Bool
ShowVal.is_unquoted_body Char
c
    Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';' -- This is so the ; separator can appear anywhere.
    -- TODO remove it when I remove VSeparator

is_word_char :: Char -> Bool
is_word_char :: Char -> Bool
is_word_char Char
c = Char -> Bool
is_toplevel_word_char Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')'

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

-- | Skip spaces, including a newline as long as the next line, skipping empty
-- lines, is indented.
spaces :: A.Parser ()
spaces :: Parser ()
spaces = do
    Parser ()
spaces_to_eol
    () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option () (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ do
        (Char -> Bool) -> Parser ()
A.skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n')
        Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
A.skipMany Parser ()
empty_line
        -- The next non-empty line has to be indented.
        (Char -> Bool) -> Parser ()
A.skip Char -> Bool
is_whitespace
        (Char -> Bool) -> Parser ()
A.skipWhile Char -> Bool
is_whitespace

-- | Like 'spaces', but require a space at the beginning.
spaces1 :: A.Parser ()
spaces1 :: Parser ()
spaces1 = Char -> Parser Char
A.char Char
' ' Parser Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
spaces

empty_line :: A.Parser ()
empty_line :: Parser ()
empty_line = Parser ()
spaces_to_eol Parser () -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser ()
A.skip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n')

spaces_to_eol :: A.Parser ()
spaces_to_eol :: Parser ()
spaces_to_eol = do
    (Char -> Bool) -> Parser ()
A.skipWhile Char -> Bool
is_whitespace
    Text
comment <- Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Text
"" (Text -> Parser Text
A.string Text
"--")
    Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
comment) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
        (Char -> Bool) -> Parser ()
A.skipWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')

is_whitespace :: Char -> Bool
is_whitespace :: Char -> Bool
is_whitespace Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'

optional :: Applicative.Alternative f => f a -> f (Maybe a)
optional :: forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional = Maybe a -> f (Maybe a) -> f (Maybe a)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Maybe a
forall a. Maybe a
Nothing (f (Maybe a) -> f (Maybe a))
-> (f a -> f (Maybe a)) -> f a -> f (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> f a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just