-- Copyright 2017 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 DeriveFunctor #-}
-- | The 'Str' and 'Symbol' types, and 'ToExpr' class.
--
-- They are split into a module with few dependencies so modules can make exprs
-- without incurring a dependency on "Derive.DeriveT", and specifically
-- 'Derive.DeriveT.Val', which drags in tons of stuff.
module Derive.Expr where
import qualified Control.DeepSeq as DeepSeq
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.String as String
import qualified Data.Text as Text

import qualified Util.Seq as Seq
import qualified Util.Serialize as Serialize
import qualified Derive.ScoreT as ScoreT
import           Derive.ShowVal (ShowVal(show_val))
import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import Global


-- | A full toplevel expression, sometimes called a "pipeline", because it looks
-- like "transform | transform | generator arg arg".  Since the only operator
-- is @|@, which is basically just application, a list suffices for an AST.
--
-- This is parameterized by the literal value, so a tokenized expr is
-- @Expr Text@ while fully parsed one would be @Expr Val@.
type Expr val = NonEmpty (Call val)
data Call val = Call Symbol [Term val]
    deriving (Int -> Call val -> ShowS
[Call val] -> ShowS
Call val -> String
(Int -> Call val -> ShowS)
-> (Call val -> String) -> ([Call val] -> ShowS) -> Show (Call val)
forall val. Show val => Int -> Call val -> ShowS
forall val. Show val => [Call val] -> ShowS
forall val. Show val => Call val -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Call val] -> ShowS
$cshowList :: forall val. Show val => [Call val] -> ShowS
show :: Call val -> String
$cshow :: forall val. Show val => Call val -> String
showsPrec :: Int -> Call val -> ShowS
$cshowsPrec :: forall val. Show val => Int -> Call val -> ShowS
Show, ReadPrec [Call val]
ReadPrec (Call val)
Int -> ReadS (Call val)
ReadS [Call val]
(Int -> ReadS (Call val))
-> ReadS [Call val]
-> ReadPrec (Call val)
-> ReadPrec [Call val]
-> Read (Call val)
forall val. Read val => ReadPrec [Call val]
forall val. Read val => ReadPrec (Call val)
forall val. Read val => Int -> ReadS (Call val)
forall val. Read val => ReadS [Call val]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Call val]
$creadListPrec :: forall val. Read val => ReadPrec [Call val]
readPrec :: ReadPrec (Call val)
$creadPrec :: forall val. Read val => ReadPrec (Call val)
readList :: ReadS [Call val]
$creadList :: forall val. Read val => ReadS [Call val]
readsPrec :: Int -> ReadS (Call val)
$creadsPrec :: forall val. Read val => Int -> ReadS (Call val)
Read, Call val -> Call val -> Bool
(Call val -> Call val -> Bool)
-> (Call val -> Call val -> Bool) -> Eq (Call val)
forall val. Eq val => Call val -> Call val -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Call val -> Call val -> Bool
$c/= :: forall val. Eq val => Call val -> Call val -> Bool
== :: Call val -> Call val -> Bool
$c== :: forall val. Eq val => Call val -> Call val -> Bool
Eq, (forall a b. (a -> b) -> Call a -> Call b)
-> (forall a b. a -> Call b -> Call a) -> Functor Call
forall a b. a -> Call b -> Call a
forall a b. (a -> b) -> Call a -> Call b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Call b -> Call a
$c<$ :: forall a b. a -> Call b -> Call a
fmap :: forall a b. (a -> b) -> Call a -> Call b
$cfmap :: forall a b. (a -> b) -> Call a -> Call b
Functor)
data Term val = ValCall (Call val) | Literal val
    deriving (Int -> Term val -> ShowS
[Term val] -> ShowS
Term val -> String
(Int -> Term val -> ShowS)
-> (Term val -> String) -> ([Term val] -> ShowS) -> Show (Term val)
forall val. Show val => Int -> Term val -> ShowS
forall val. Show val => [Term val] -> ShowS
forall val. Show val => Term val -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Term val] -> ShowS
$cshowList :: forall val. Show val => [Term val] -> ShowS
show :: Term val -> String
$cshow :: forall val. Show val => Term val -> String
showsPrec :: Int -> Term val -> ShowS
$cshowsPrec :: forall val. Show val => Int -> Term val -> ShowS
Show, ReadPrec [Term val]
ReadPrec (Term val)
Int -> ReadS (Term val)
ReadS [Term val]
(Int -> ReadS (Term val))
-> ReadS [Term val]
-> ReadPrec (Term val)
-> ReadPrec [Term val]
-> Read (Term val)
forall val. Read val => ReadPrec [Term val]
forall val. Read val => ReadPrec (Term val)
forall val. Read val => Int -> ReadS (Term val)
forall val. Read val => ReadS [Term val]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Term val]
$creadListPrec :: forall val. Read val => ReadPrec [Term val]
readPrec :: ReadPrec (Term val)
$creadPrec :: forall val. Read val => ReadPrec (Term val)
readList :: ReadS [Term val]
$creadList :: forall val. Read val => ReadS [Term val]
readsPrec :: Int -> ReadS (Term val)
$creadsPrec :: forall val. Read val => Int -> ReadS (Term val)
Read, Term val -> Term val -> Bool
(Term val -> Term val -> Bool)
-> (Term val -> Term val -> Bool) -> Eq (Term val)
forall val. Eq val => Term val -> Term val -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Term val -> Term val -> Bool
$c/= :: forall val. Eq val => Term val -> Term val -> Bool
== :: Term val -> Term val -> Bool
$c== :: forall val. Eq val => Term val -> Term val -> Bool
Eq, (forall a b. (a -> b) -> Term a -> Term b)
-> (forall a b. a -> Term b -> Term a) -> Functor Term
forall a b. a -> Term b -> Term a
forall a b. (a -> b) -> Term a -> Term b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Term b -> Term a
$c<$ :: forall a b. a -> Term b -> Term a
fmap :: forall a b. (a -> b) -> Term a -> Term b
$cfmap :: forall a b. (a -> b) -> Term a -> Term b
Functor)

instance String.IsString (Call val) where
    fromString :: String -> Call val
fromString = Symbol -> Call val
forall val. Symbol -> Call val
call0 (Symbol -> Call val) -> (String -> Symbol) -> String -> Call val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Symbol
forall a. IsString a => String -> a
String.fromString
instance String.IsString (Expr val) where
    fromString :: String -> Expr val
fromString = Symbol -> Expr val
forall val. Symbol -> Expr val
generator0 (Symbol -> Expr val) -> (String -> Symbol) -> String -> Expr val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Symbol
forall a. IsString a => String -> a
String.fromString

-- These ShowVal instances are tested in Derive.Parse_test:

instance ShowVal (Expr Text) where show_val :: Expr Text -> Text
show_val = Expr Text -> Text
forall val. ShowVal (Call val) => Expr val -> Text
show_val_expr
instance ShowVal (Call Text) where show_val :: Call Text -> Text
show_val = (Text -> Maybe Text) -> Call Text -> Text
forall val.
ShowVal (Term val) =>
(val -> Maybe Text) -> Call val -> Text
show_val_call (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (Text -> Text) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall a. a -> a
id)
instance ShowVal (Term Text) where show_val :: Term Text -> Text
show_val = Term Text -> Text
forall val. (ShowVal val, ShowVal (Call val)) => Term val -> Text
show_val_term

instance ShowVal (Expr MiniVal) where show_val :: Expr MiniVal -> Text
show_val = Expr MiniVal -> Text
forall val. ShowVal (Call val) => Expr val -> Text
show_val_expr
instance ShowVal (Call MiniVal) where
    show_val :: Call MiniVal -> Text
show_val = (MiniVal -> Maybe Text) -> Call MiniVal -> Text
forall val.
ShowVal (Term val) =>
(val -> Maybe Text) -> Call val -> Text
show_val_call ((MiniVal -> Maybe Text) -> Call MiniVal -> Text)
-> (MiniVal -> Maybe Text) -> Call MiniVal -> Text
forall a b. (a -> b) -> a -> b
$ \case
        VStr (Str Text
op) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
op
        MiniVal
_ -> Maybe Text
forall a. Maybe a
Nothing
instance ShowVal (Term MiniVal) where show_val :: Term MiniVal -> Text
show_val = Term MiniVal -> Text
forall val. (ShowVal val, ShowVal (Call val)) => Term val -> Text
show_val_term

instance Pretty (Call Text) where pretty :: Call Text -> Text
pretty = Call Text -> Text
forall a. ShowVal a => a -> Text
show_val
instance Pretty (Term Text) where pretty :: Term Text -> Text
pretty = Term Text -> Text
forall a. ShowVal a => a -> Text
show_val
instance Pretty (Call MiniVal) where pretty :: Call MiniVal -> Text
pretty = Call MiniVal -> Text
forall a. ShowVal a => a -> Text
show_val
instance Pretty (Term MiniVal) where pretty :: Term MiniVal -> Text
pretty = Term MiniVal -> Text
forall a. ShowVal a => a -> Text
show_val

-- Previously I used 'instance ShowVal val => ShowVal (Expr val)', but that
-- doesn't let me have a specialized version for Call Val, unless I want to do
-- overlapping instances, which I don't.

show_val_expr :: ShowVal (Call val) => Expr val -> Text
show_val_expr :: forall val. ShowVal (Call val) => Expr val -> Text
show_val_expr = Text -> Text
Text.strip (Text -> Text) -> (Expr val -> Text) -> Expr val -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
" | " ([Text] -> Text) -> (Expr val -> [Text]) -> Expr val -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Call val -> Text) -> [Call val] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Call val -> Text
forall a. ShowVal a => a -> Text
show_val
    ([Call val] -> [Text])
-> (Expr val -> [Call val]) -> Expr val -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr val -> [Call val]
forall a. NonEmpty a -> [a]
NonEmpty.toList

show_val_call :: ShowVal (Term val) => (val -> Maybe Text) -> Call val -> Text
show_val_call :: forall val.
ShowVal (Term val) =>
(val -> Maybe Text) -> Call val -> Text
show_val_call val -> Maybe Text
literal_str_of = \case
    -- This inverts 'Derive.Parse.p_equal'.
    Call (Symbol Text
"=") [Term val
lhs, Term val
rhs] ->
        [Text] -> Text
Text.unwords [Term val -> Text
forall a. ShowVal a => a -> Text
show_val Term val
lhs, Text
"=", Term val -> Text
forall a. ShowVal a => a -> Text
show_val Term val
rhs]
    Call (Symbol Text
"=") [Term val
lhs, Term val
rhs, Literal val
op]
        | Just Text
op <- val -> Maybe Text
literal_str_of val
op -> [Text] -> Text
Text.unwords
            [ Term val -> Text
forall a. ShowVal a => a -> Text
show_val Term val
lhs
            , Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
op
            , Term val -> Text
forall a. ShowVal a => a -> Text
show_val Term val
rhs
            ]
    Call (Symbol Text
sym) [Term val]
terms -> [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
sym Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Term val -> Text) -> [Term val] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Term val -> Text
forall a. ShowVal a => a -> Text
show_val [Term val]
terms

show_val_term :: (ShowVal val, ShowVal (Call val)) => Term val -> Text
show_val_term :: forall val. (ShowVal val, ShowVal (Call val)) => Term val -> Text
show_val_term = \case
    ValCall Call val
call -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Call val -> Text
forall a. ShowVal a => a -> Text
show_val Call val
call Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    Literal val
val -> val -> Text
forall a. ShowVal a => a -> Text
show_val val
val

-- | Name of a call, used to look it up in the namespace.
--
-- This is parsed by Parse.p_call_symbol, so it can have any character except
-- space, =, or ) for val calls.  It's not enforced though, especially since
-- there's an IsString instance, but if you put in a space you'll get a messed
-- up expression.
newtype Symbol = Symbol Text
    deriving (Symbol -> Symbol -> Bool
(Symbol -> Symbol -> Bool)
-> (Symbol -> Symbol -> Bool) -> Eq Symbol
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Symbol -> Symbol -> Bool
$c/= :: Symbol -> Symbol -> Bool
== :: Symbol -> Symbol -> Bool
$c== :: Symbol -> Symbol -> Bool
Eq, Eq Symbol
Eq Symbol
-> (Symbol -> Symbol -> Ordering)
-> (Symbol -> Symbol -> Bool)
-> (Symbol -> Symbol -> Bool)
-> (Symbol -> Symbol -> Bool)
-> (Symbol -> Symbol -> Bool)
-> (Symbol -> Symbol -> Symbol)
-> (Symbol -> Symbol -> Symbol)
-> Ord Symbol
Symbol -> Symbol -> Bool
Symbol -> Symbol -> Ordering
Symbol -> Symbol -> Symbol
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Symbol -> Symbol -> Symbol
$cmin :: Symbol -> Symbol -> Symbol
max :: Symbol -> Symbol -> Symbol
$cmax :: Symbol -> Symbol -> Symbol
>= :: Symbol -> Symbol -> Bool
$c>= :: Symbol -> Symbol -> Bool
> :: Symbol -> Symbol -> Bool
$c> :: Symbol -> Symbol -> Bool
<= :: Symbol -> Symbol -> Bool
$c<= :: Symbol -> Symbol -> Bool
< :: Symbol -> Symbol -> Bool
$c< :: Symbol -> Symbol -> Bool
compare :: Symbol -> Symbol -> Ordering
$ccompare :: Symbol -> Symbol -> Ordering
Ord, ReadPrec [Symbol]
ReadPrec Symbol
Int -> ReadS Symbol
ReadS [Symbol]
(Int -> ReadS Symbol)
-> ReadS [Symbol]
-> ReadPrec Symbol
-> ReadPrec [Symbol]
-> Read Symbol
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Symbol]
$creadListPrec :: ReadPrec [Symbol]
readPrec :: ReadPrec Symbol
$creadPrec :: ReadPrec Symbol
readList :: ReadS [Symbol]
$creadList :: ReadS [Symbol]
readsPrec :: Int -> ReadS Symbol
$creadsPrec :: Int -> ReadS Symbol
Read, Int -> Symbol -> ShowS
[Symbol] -> ShowS
Symbol -> String
(Int -> Symbol -> ShowS)
-> (Symbol -> String) -> ([Symbol] -> ShowS) -> Show Symbol
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Symbol] -> ShowS
$cshowList :: [Symbol] -> ShowS
show :: Symbol -> String
$cshow :: Symbol -> String
showsPrec :: Int -> Symbol -> ShowS
$cshowsPrec :: Int -> Symbol -> ShowS
Show, NonEmpty Symbol -> Symbol
Symbol -> Symbol -> Symbol
(Symbol -> Symbol -> Symbol)
-> (NonEmpty Symbol -> Symbol)
-> (forall b. Integral b => b -> Symbol -> Symbol)
-> Semigroup Symbol
forall b. Integral b => b -> Symbol -> Symbol
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Symbol -> Symbol
$cstimes :: forall b. Integral b => b -> Symbol -> Symbol
sconcat :: NonEmpty Symbol -> Symbol
$csconcat :: NonEmpty Symbol -> Symbol
<> :: Symbol -> Symbol -> Symbol
$c<> :: Symbol -> Symbol -> Symbol
Semigroup, Semigroup Symbol
Symbol
Semigroup Symbol
-> Symbol
-> (Symbol -> Symbol -> Symbol)
-> ([Symbol] -> Symbol)
-> Monoid Symbol
[Symbol] -> Symbol
Symbol -> Symbol -> Symbol
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Symbol] -> Symbol
$cmconcat :: [Symbol] -> Symbol
mappend :: Symbol -> Symbol -> Symbol
$cmappend :: Symbol -> Symbol -> Symbol
mempty :: Symbol
$cmempty :: Symbol
Monoid, Symbol -> ()
(Symbol -> ()) -> NFData Symbol
forall a. (a -> ()) -> NFData a
rnf :: Symbol -> ()
$crnf :: Symbol -> ()
DeepSeq.NFData,
        String -> Symbol
(String -> Symbol) -> IsString Symbol
forall a. (String -> a) -> IsString a
fromString :: String -> Symbol
$cfromString :: String -> Symbol
String.IsString, [Symbol] -> Doc
Symbol -> Text
Symbol -> Doc
(Symbol -> Text)
-> (Symbol -> Doc) -> ([Symbol] -> Doc) -> Pretty Symbol
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [Symbol] -> Doc
$cformatList :: [Symbol] -> Doc
format :: Symbol -> Doc
$cformat :: Symbol -> Doc
pretty :: Symbol -> Text
$cpretty :: Symbol -> Text
Pretty, Get Symbol
Putter Symbol
Putter Symbol -> Get Symbol -> Serialize Symbol
forall a. Putter a -> Get a -> Serialize a
get :: Get Symbol
$cget :: Get Symbol
put :: Putter Symbol
$cput :: Putter Symbol
Serialize.Serialize)

unsym :: Symbol -> Text
unsym :: Symbol -> Text
unsym (Symbol Text
sym) = Text
sym

instance ShowVal Symbol where
    show_val :: Symbol -> Text
show_val (Symbol Text
sym) = Text
sym

expr :: [Call val] -> Call val -> Expr val
expr :: forall val. [Call val] -> Call val -> Expr val
expr [Call val]
trans Call val
gen = Call val
hd Call val -> [Call val] -> NonEmpty (Call val)
forall a. a -> [a] -> NonEmpty a
:| [Call val]
tl
    where Call val
hd : [Call val]
tl = [Call val]
trans [Call val] -> [Call val] -> [Call val]
forall a. [a] -> [a] -> [a]
++ [Call val
gen]

generator :: Call val -> Expr val
generator :: forall val. Call val -> Expr val
generator = [Call val] -> Call val -> Expr val
forall val. [Call val] -> Call val -> Expr val
expr []

-- | Generator with no arguments.
generator0 :: Symbol -> Expr val
generator0 :: forall val. Symbol -> Expr val
generator0 = Call val -> Expr val
forall val. Call val -> Expr val
generator (Call val -> Expr val)
-> (Symbol -> Call val) -> Symbol -> Expr val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Call val
forall val. Symbol -> Call val
call0

-- | Split into (transformers, generator).  Inverse of 'expr'.
split :: Expr val -> ([Call val], Call val)
split :: forall val. Expr val -> ([Call val], Call val)
split = NonEmpty (Call val) -> ([Call val], Call val)
forall a. NonEmpty a -> ([a], a)
Seq.ne_viewr

-- | Make a Call with Literal args.
call :: Symbol -> [val] -> Call val
call :: forall val. Symbol -> [val] -> Call val
call Symbol
sym [val]
args = Symbol -> [Term val] -> Call val
forall val. Symbol -> [Term val] -> Call val
Call Symbol
sym ((val -> Term val) -> [val] -> [Term val]
forall a b. (a -> b) -> [a] -> [b]
map val -> Term val
forall val. val -> Term val
Literal [val]
args)

call0 :: Symbol -> Call val
call0 :: forall val. Symbol -> Call val
call0 Symbol
sym = Symbol -> [Term val] -> Call val
forall val. Symbol -> [Term val] -> Call val
Call Symbol
sym []

val_call :: Symbol -> [a] -> Term a
val_call :: forall a. Symbol -> [a] -> Term a
val_call Symbol
sym [a]
args = Call a -> Term a
forall val. Call val -> Term val
ValCall (Symbol -> [a] -> Call a
forall val. Symbol -> [val] -> Call val
call Symbol
sym [a]
args)

transform :: Call a -> Expr a -> Expr a
transform :: forall a. Call a -> Expr a -> Expr a
transform Call a
call (Call a
hd :| [Call a]
tl) = Call a
call Call a -> [Call a] -> NonEmpty (Call a)
forall a. a -> [a] -> NonEmpty a
:| (Call a
hd Call a -> [Call a] -> [Call a]
forall a. a -> [a] -> [a]
: [Call a]
tl)

transform0 :: Symbol -> Expr a -> Expr a
transform0 :: forall a. Symbol -> Expr a -> Expr a
transform0 = Call a -> Expr a -> Expr a
forall a. Call a -> Expr a -> Expr a
transform (Call a -> Expr a -> Expr a)
-> (Symbol -> Call a) -> Symbol -> Expr a -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Call a
forall val. Symbol -> Call val
call0

-- | Shortcut to transform an Expr.
with :: ToExpr a => Symbol -> a -> Expr MiniVal
with :: forall a. ToExpr a => Symbol -> a -> Expr MiniVal
with Symbol
sym = Symbol -> Expr MiniVal -> Expr MiniVal
forall a. Symbol -> Expr a -> Expr a
transform0 Symbol
sym (Expr MiniVal -> Expr MiniVal)
-> (a -> Expr MiniVal) -> a -> Expr MiniVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Expr MiniVal
forall a. ToExpr a => a -> Expr MiniVal
to_expr

-- ** transform

str_to_scale_id :: Str -> Pitch.ScaleId
str_to_scale_id :: Str -> ScaleId
str_to_scale_id = Text -> ScaleId
Pitch.ScaleId (Text -> ScaleId) -> (Str -> Text) -> Str -> ScaleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> Text
unstr

scale_id_to_str :: Pitch.ScaleId -> Str
scale_id_to_str :: ScaleId -> Str
scale_id_to_str (Pitch.ScaleId Text
s) = Text -> Str
Str Text
s

map_symbol :: (Symbol -> Symbol) -> Call a -> Call a
map_symbol :: forall a. (Symbol -> Symbol) -> Call a -> Call a
map_symbol Symbol -> Symbol
f (Call Symbol
call [Term a]
args) = Symbol -> [Term a] -> Call a
forall val. Symbol -> [Term val] -> Call val
Call (Symbol -> Symbol
f Symbol
call) [Term a]
args

-- | Transform the 'Literal's in an expression.
map_literals :: (a -> b) -> Expr a -> Expr b
map_literals :: forall a b. (a -> b) -> Expr a -> Expr b
map_literals = (Call a -> Call b) -> NonEmpty (Call a) -> NonEmpty (Call b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Call a -> Call b) -> NonEmpty (Call a) -> NonEmpty (Call b))
-> ((a -> b) -> Call a -> Call b)
-> (a -> b)
-> NonEmpty (Call a)
-> NonEmpty (Call b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Call a -> Call b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

-- | Transform only the Symbol in the generator position.
map_generator :: (Symbol -> Symbol) -> Expr a -> Expr a
map_generator :: forall a. (Symbol -> Symbol) -> Expr a -> Expr a
map_generator Symbol -> Symbol
f (Call a
call1 :| [Call a]
calls) = case [Call a]
calls of
    [] -> (Symbol -> Symbol) -> Call a -> Call a
forall a. (Symbol -> Symbol) -> Call a -> Call a
map_symbol Symbol -> Symbol
f Call a
call1 Call a -> [Call a] -> NonEmpty (Call a)
forall a. a -> [a] -> NonEmpty a
:| []
    Call a
_ : [Call a]
_ -> Call a
call1 Call a -> [Call a] -> NonEmpty (Call a)
forall a. a -> [a] -> NonEmpty a
:| (Call a -> Call a) -> [Call a] -> [Call a]
forall a. (a -> a) -> [a] -> [a]
Seq.map_last ((Symbol -> Symbol) -> Call a -> Call a
forall a. (Symbol -> Symbol) -> Call a -> Call a
map_symbol Symbol -> Symbol
f) [Call a]
calls

-- * ToExpr

-- | This is meant for types which can be turned into a tracklang expression.
-- For example, drum strokes might have a parsed form which can be turned into
-- calls.
class ToExpr a where
    to_expr :: a -> Expr MiniVal

-- * Str

newtype Str = Str Text
    deriving (Str -> Str -> Bool
(Str -> Str -> Bool) -> (Str -> Str -> Bool) -> Eq Str
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Str -> Str -> Bool
$c/= :: Str -> Str -> Bool
== :: Str -> Str -> Bool
$c== :: Str -> Str -> Bool
Eq, Eq Str
Eq Str
-> (Str -> Str -> Ordering)
-> (Str -> Str -> Bool)
-> (Str -> Str -> Bool)
-> (Str -> Str -> Bool)
-> (Str -> Str -> Bool)
-> (Str -> Str -> Str)
-> (Str -> Str -> Str)
-> Ord Str
Str -> Str -> Bool
Str -> Str -> Ordering
Str -> Str -> Str
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Str -> Str -> Str
$cmin :: Str -> Str -> Str
max :: Str -> Str -> Str
$cmax :: Str -> Str -> Str
>= :: Str -> Str -> Bool
$c>= :: Str -> Str -> Bool
> :: Str -> Str -> Bool
$c> :: Str -> Str -> Bool
<= :: Str -> Str -> Bool
$c<= :: Str -> Str -> Bool
< :: Str -> Str -> Bool
$c< :: Str -> Str -> Bool
compare :: Str -> Str -> Ordering
$ccompare :: Str -> Str -> Ordering
Ord, ReadPrec [Str]
ReadPrec Str
Int -> ReadS Str
ReadS [Str]
(Int -> ReadS Str)
-> ReadS [Str] -> ReadPrec Str -> ReadPrec [Str] -> Read Str
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Str]
$creadListPrec :: ReadPrec [Str]
readPrec :: ReadPrec Str
$creadPrec :: ReadPrec Str
readList :: ReadS [Str]
$creadList :: ReadS [Str]
readsPrec :: Int -> ReadS Str
$creadsPrec :: Int -> ReadS Str
Read, Int -> Str -> ShowS
[Str] -> ShowS
Str -> String
(Int -> Str -> ShowS)
-> (Str -> String) -> ([Str] -> ShowS) -> Show Str
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Str] -> ShowS
$cshowList :: [Str] -> ShowS
show :: Str -> String
$cshow :: Str -> String
showsPrec :: Int -> Str -> ShowS
$cshowsPrec :: Int -> Str -> ShowS
Show, Str -> ()
(Str -> ()) -> NFData Str
forall a. (a -> ()) -> NFData a
rnf :: Str -> ()
$crnf :: Str -> ()
DeepSeq.NFData, String -> Str
(String -> Str) -> IsString Str
forall a. (String -> a) -> IsString a
fromString :: String -> Str
$cfromString :: String -> Str
String.IsString,
        Get Str
Putter Str
Putter Str -> Get Str -> Serialize Str
forall a. Putter a -> Get a -> Serialize a
get :: Get Str
$cget :: Get Str
put :: Putter Str
$cput :: Putter Str
Serialize.Serialize, Str -> Text
(Str -> Text) -> ShowVal Str
forall a. (a -> Text) -> ShowVal a
show_val :: Str -> Text
$cshow_val :: Str -> Text
ShowVal)
instance Pretty Str where pretty :: Str -> Text
pretty = Str -> Text
forall a. ShowVal a => a -> Text
show_val

unstr :: Str -> Text
unstr :: Str -> Text
unstr (Str Text
str) = Text
str

-- * MiniVal

-- | Yes, it's yet another Val variant.  This one is even more mini than
-- REnv.Val.
-- TODO NOTE [val-and-minival]
data MiniVal = VNum !(ScoreT.Typed Signal.Y) | VStr !Str
    deriving (MiniVal -> MiniVal -> Bool
(MiniVal -> MiniVal -> Bool)
-> (MiniVal -> MiniVal -> Bool) -> Eq MiniVal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MiniVal -> MiniVal -> Bool
$c/= :: MiniVal -> MiniVal -> Bool
== :: MiniVal -> MiniVal -> Bool
$c== :: MiniVal -> MiniVal -> Bool
Eq, Eq MiniVal
Eq MiniVal
-> (MiniVal -> MiniVal -> Ordering)
-> (MiniVal -> MiniVal -> Bool)
-> (MiniVal -> MiniVal -> Bool)
-> (MiniVal -> MiniVal -> Bool)
-> (MiniVal -> MiniVal -> Bool)
-> (MiniVal -> MiniVal -> MiniVal)
-> (MiniVal -> MiniVal -> MiniVal)
-> Ord MiniVal
MiniVal -> MiniVal -> Bool
MiniVal -> MiniVal -> Ordering
MiniVal -> MiniVal -> MiniVal
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MiniVal -> MiniVal -> MiniVal
$cmin :: MiniVal -> MiniVal -> MiniVal
max :: MiniVal -> MiniVal -> MiniVal
$cmax :: MiniVal -> MiniVal -> MiniVal
>= :: MiniVal -> MiniVal -> Bool
$c>= :: MiniVal -> MiniVal -> Bool
> :: MiniVal -> MiniVal -> Bool
$c> :: MiniVal -> MiniVal -> Bool
<= :: MiniVal -> MiniVal -> Bool
$c<= :: MiniVal -> MiniVal -> Bool
< :: MiniVal -> MiniVal -> Bool
$c< :: MiniVal -> MiniVal -> Bool
compare :: MiniVal -> MiniVal -> Ordering
$ccompare :: MiniVal -> MiniVal -> Ordering
Ord, Int -> MiniVal -> ShowS
[MiniVal] -> ShowS
MiniVal -> String
(Int -> MiniVal -> ShowS)
-> (MiniVal -> String) -> ([MiniVal] -> ShowS) -> Show MiniVal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MiniVal] -> ShowS
$cshowList :: [MiniVal] -> ShowS
show :: MiniVal -> String
$cshow :: MiniVal -> String
showsPrec :: Int -> MiniVal -> ShowS
$cshowsPrec :: Int -> MiniVal -> ShowS
Show)

instance String.IsString MiniVal where
    fromString :: String -> MiniVal
fromString = Str -> MiniVal
VStr(Str -> MiniVal) -> (String -> Str) -> String -> MiniVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Str
forall a. IsString a => String -> a
String.fromString

instance ShowVal MiniVal where
    show_val :: MiniVal -> Text
show_val (VNum Typed Y
v) = Typed Y -> Text
forall a. ShowVal a => a -> Text
show_val Typed Y
v
    show_val (VStr Str
v) = Str -> Text
forall a. ShowVal a => a -> Text
show_val Str
v

instance Pretty MiniVal where pretty :: MiniVal -> Text
pretty = MiniVal -> Text
forall a. ShowVal a => a -> Text
show_val

instance Serialize.Serialize MiniVal where
    put :: Putter MiniVal
put (VNum Typed Y
a) = Word8 -> Put
Serialize.put_tag Word8
0 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter (Typed Y)
forall a. Serialize a => Putter a
Serialize.put Typed Y
a
    put (VStr Str
a) = Word8 -> Put
Serialize.put_tag Word8
1 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Str
forall a. Serialize a => Putter a
Serialize.put Str
a
    get :: Get MiniVal
get = Get Word8
Serialize.get_tag Get Word8 -> (Word8 -> Get MiniVal) -> Get MiniVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Word8
0 -> Typed Y -> MiniVal
VNum (Typed Y -> MiniVal) -> Get (Typed Y) -> Get MiniVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Typed Y)
forall a. Serialize a => Get a
Serialize.get
        Word8
1 -> Str -> MiniVal
VStr (Str -> MiniVal) -> Get Str -> Get MiniVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Str
forall a. Serialize a => Get a
Serialize.get
        Word8
tag -> String -> Word8 -> Get MiniVal
forall a. String -> Word8 -> Get a
Serialize.bad_tag String
"MiniVal" Word8
tag

class ToVal a where to_val :: a -> MiniVal

instance ToVal Int where to_val :: Int -> MiniVal
to_val Int
a = Y -> MiniVal
forall a. ToVal a => a -> MiniVal
to_val (Int -> Y
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a :: Double)
instance ToVal Double where to_val :: Y -> MiniVal
to_val = Typed Y -> MiniVal
VNum (Typed Y -> MiniVal) -> (Y -> Typed Y) -> Y -> MiniVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Typed Y
forall a. a -> Typed a
ScoreT.untyped
instance ToVal Text where to_val :: Text -> MiniVal
to_val = Str -> MiniVal
VStr (Str -> MiniVal) -> (Text -> Str) -> Text -> MiniVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Str
Str