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

{- | Functions to help define call signatures.

    This module, along with the 'Typecheck.Typecheck' class, define a little
    DSL to express function signatures.  Check existing calls for examples.

    Argument passing, in an effort to be flexible, got a bit complicated.  Each
    'Arg' has a name and a possible default.  So right off there are three ways
    to provide an argument:

    1. Pass it explicitly.

    2. If it is omitted, or @_@ is passed explicitly, it will be sought in the
    dynamic environ, under the name @\<call_name>-\<arg_name>@.  E.g. given
    a call @generator \"name\" $ \\args -> call (required \"arg1\") ...@ then
    @name-arg1 = 42 | call _@ will get 42.  Note that it uses the call name,
    and not the symbol it happens to bound to in this scope.  This is because,
    while you may bind different kinds of trills to @tr@ depending on the needs
    of the score, the two kinds of trills may have different arguments with
    different meanings.

    3. If it's omitted, and not in the dynamic environ, the default will be
    used, provided there is one.

    In addition, an arg may be a 'DeriveT.VPControlRef' or
    'DeriveT.ControlRef', which introduces yet another way to provide the
    value.  An argument @required_control \"c\"@ will pass
    a 'DeriveT.LiteralControl'.  Technically it's then up to the call to
    decide what to do with it, but it will likely look it up at its chosen
    point in time, which means you can provide the value by providing a @c@
    control track or binding it explicitly e.g. @%c = .5 | call@.

    - To further complicate the matter, the control arg may itself have a
    default, to relieve the caller from always having to provide that control.
    So an argument @control \"c\" 0.5@ or an explicitly provided control val
    @call %c,.5@ will default to 0.5 if the @c@ control is not in scope.

    Since the arg defaulting and control defaulting are orthogonal, they can be
    combined:

    1. Pass it explicitly with a default: @call %c,.5@.  This is either the
    value of @%c@ or 0.5.

    2. Pass it via the dynamic environ: @call-arg1 = %c,.5 | call@.  This is
    the same as the above, only the argument is provided implicitly.

    3. Fall back on the built-in default: @control \"c\" 0.5@ and then just
    @call@.

    I originally envisioned the dynamic environ passing scheme to be a way to
    default certain arguments within the context of a track, to be used in
    a relatively ad-hoc way in specific parts of the score (e.g. all trills
    within this section of melody default to minor thirds), is not limited to
    numeric types, and is constant in time.  A control, however, is intended to
    capture musical parameters that change in time over the course of the
    piece, and is numeric or a pitch.  So while dynamic environ args are forced
    to be specific to a certain call by prepending the call's name, control
    names should generally have more general and abstract names.

    On the subject of controls, controls (and numeric vals in general) have
    another layer of complexity since they carry types.  For example, here's
    a gloriously complicated argument: @defaulted \"speed\" (typed_control
    \"tremolo-speed\" 10 ScoreT.Real)@.  This argument defaults to
    @%tremolo-speed,10s@.  If it's not given, it will have the value @10s@.  If
    the @%tremolo-speed@ control is in scope but untyped, its values will be
    interpreted as RealTime.  If it's in scope and typed (e.g. with
    a @tremolo-speed:t@ track), then its values will be interpreted as
    ScoreTime.

    Another wrinkle in argument passing is that, in addition to being
    'required', which has no default, or being 'defaulted', which has
    a default, they can be 'defaulted' with a default of Nothing.  This passes
    the argument as a @Maybe a@ instead of @a@ and lets the call distinguish
    whether an argument was provided or not.  This is for arguments which are
    defaulted but need a more complicated defaulting strategy than simply
    a constant.
-}
module Derive.Sig (
    Parser, Generator, Transformer
    , Arg(..)
    , check, parse_or_throw, require_right, parse, parse_vals
    -- * parsers
    , no_args
    , required, required_env
    , defaulted, defaulted_env, defaulted_env_quoted, maybe_defaulted
    , environ, environ_key, environ_quoted
    , required_environ, required_environ_key
    , optional, optional_env, many, many_vals, many1, many_pairs, many1_pairs
    , required_vals
    -- ** defaults
    , EnvironDefault(..)
    , control, typed_control, required_control, pitch
    , prefixed_environ, environ_keys
    -- * call
    , call, call_sub, call0, callt, call0t
) where
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Util.Pretty as Pretty
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.SubT as SubT
import qualified Derive.Derive as Derive
import           Derive.Derive (ArgName, CallName, EnvironDefault(..))
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck
import qualified Derive.ValType as ValType

import qualified Perform.Signal as Signal
import qualified Ui.Event as Event

import           Global


type Error = Derive.CallError
type Docs = [Derive.ArgDoc]

data Parser a = Parser {
    forall a. Parser a -> Docs
parser_docs :: !Docs
    , forall a. Parser a -> State -> Either Error (State, a)
parser_parser :: !(State -> Either Error (State, a))
    }

parser :: Derive.ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser :: forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc = Docs -> (State -> Either Error (State, a)) -> Parser a
forall a. Docs -> (State -> Either Error (State, a)) -> Parser a
Parser [ArgDoc
arg_doc]

-- | Keep track of state when parsing arguments.
data State = State {
    State -> [Arg]
state_vals :: ![Arg]
    -- | This has to be incremented every time a Val is taken.  Pairing argnums
    -- in state_vals doesn't work because when I run out I don't know where
    -- I am.
    , State -> Int
state_argnum :: !Int
    , State -> CallName
state_call_name :: !CallName
    , State -> State
state_derive :: !Derive.State
    , State -> Context Tagged
state_context :: !(Derive.Context Derive.Tagged)
    }

data Arg = LiteralArg !DeriveT.Val | SubTrack !SubT.Track

instance Pretty Arg where
    format :: Arg -> Doc
format (LiteralArg Val
val) = Val -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Val
val
    format (SubTrack Track
track) = Track -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Track
track

show_arg :: Arg -> Text
show_arg :: Arg -> Key
show_arg (LiteralArg Val
val) = Val -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Val
val
show_arg (SubTrack Track
track) = Track -> Key
SubT.show_track Track
track

run_parser :: Parser a -> State -> Either Error a
run_parser :: forall a. Parser a -> State -> Either Error a
run_parser Parser a
parser State
state = case Parser a -> State -> Either Error (State, a)
forall a. Parser a -> State -> Either Error (State, a)
parser_parser Parser a
parser State
state of
    Left Error
err -> Error -> Either Error a
forall a b. a -> Either a b
Left Error
err
    Right (State
state, a
a) -> case State -> [Arg]
state_vals State
state of
        [] -> a -> Either Error a
forall a b. b -> Either a b
Right a
a
        [Arg]
args -> Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a) -> Error -> Either Error a
forall a b. (a -> b) -> a -> b
$ Key -> Error
Derive.ArgError (Key -> Error) -> Key -> Error
forall a b. (a -> b) -> a -> b
$ Key
"too many arguments: "
            Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key -> [Key] -> Key
Text.intercalate Key
", " ((Arg -> Key) -> [Arg] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map Arg -> Key
show_arg [Arg]
args)

instance Functor Parser where
    fmap :: forall a b. (a -> b) -> Parser a -> Parser b
fmap a -> b
f Parser a
parser =
        Parser a
parser { parser_parser :: State -> Either Error (State, b)
parser_parser = ((State, a) -> (State, b))
-> Either Error (State, a) -> Either Error (State, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (State, a) -> (State, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (Either Error (State, a) -> Either Error (State, b))
-> (State -> Either Error (State, a))
-> State
-> Either Error (State, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> State -> Either Error (State, a)
forall a. Parser a -> State -> Either Error (State, a)
parser_parser Parser a
parser }

instance Applicative Parser where
    pure :: forall a. a -> Parser a
pure a
a = Docs -> (State -> Either Error (State, a)) -> Parser a
forall a. Docs -> (State -> Either Error (State, a)) -> Parser a
Parser Docs
forall a. Monoid a => a
mempty (\State
state -> (State, a) -> Either Error (State, a)
forall a b. b -> Either a b
Right (State
state, a
a))
    Parser Docs
doc1 State -> Either Error (State, a -> b)
parse1 <*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
<*> Parser Docs
doc2 State -> Either Error (State, a)
parse2 =
        Docs -> (State -> Either Error (State, b)) -> Parser b
forall a. Docs -> (State -> Either Error (State, a)) -> Parser a
Parser (Docs
doc1 Docs -> Docs -> Docs
forall a. Semigroup a => a -> a -> a
<> Docs
doc2) ((State -> Either Error (State, b)) -> Parser b)
-> (State -> Either Error (State, b)) -> Parser b
forall a b. (a -> b) -> a -> b
$ \State
state -> do
            (State
state, a -> b
f) <- State -> Either Error (State, a -> b)
parse1 State
state
            (State
state, a
a) <- State -> Either Error (State, a)
parse2 State
state
            (State, b) -> Either Error (State, b)
forall a b. b -> Either a b
Right (State
state, a -> b
f a
a)

-- | Annotate a parser with a check on its value.
check :: (a -> Maybe Text) -- ^ return Just error if there's a problem
    -> Parser a -> Parser a
check :: forall a. (a -> Maybe Key) -> Parser a -> Parser a
check a -> Maybe Key
validate (Parser Docs
docs State -> Either Error (State, a)
parse) = Docs -> (State -> Either Error (State, a)) -> Parser a
forall a. Docs -> (State -> Either Error (State, a)) -> Parser a
Parser Docs
docs ((State -> Either Error (State, a)) -> Parser a)
-> (State -> Either Error (State, a)) -> Parser a
forall a b. (a -> b) -> a -> b
$ \State
state -> case State -> Either Error (State, a)
parse State
state of
    Left Error
err -> Error -> Either Error (State, a)
forall a b. a -> Either a b
Left Error
err
    Right (State
state2, a
val) -> case a -> Maybe Key
validate a
val of
        Just Key
err -> Error -> Either Error (State, a)
forall a b. a -> Either a b
Left (Error -> Either Error (State, a))
-> Error -> Either Error (State, a)
forall a b. (a -> b) -> a -> b
$ Key -> Error
Derive.ArgError Key
err
        Maybe Key
Nothing -> (State, a) -> Either Error (State, a)
forall a b. b -> Either a b
Right (State
state2, a
val)

parse_or_throw :: Derive.Taggable d => Parser a -> Derive.PassedArgs d
    -> Derive.Deriver a
parse_or_throw :: forall d a. Taggable d => Parser a -> PassedArgs d -> Deriver a
parse_or_throw Parser a
parser PassedArgs d
args = Either Error a -> Deriver a
forall a. Either Error a -> Deriver a
require_right (Either Error a -> Deriver a)
-> Deriver State Error (Either Error a) -> Deriver a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser a -> PassedArgs d -> Deriver State Error (Either Error a)
forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse Parser a
parser PassedArgs d
args

require_right :: Either Error a -> Derive.Deriver a
require_right :: forall a. Either Error a -> Deriver a
require_right = (Error -> Deriver a)
-> (a -> Deriver a) -> Either Error a -> Deriver a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ErrorVal -> Deriver a
forall a. HasCallStack => ErrorVal -> Deriver a
Derive.throw_error (ErrorVal -> Deriver a)
-> (Error -> ErrorVal) -> Error -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> ErrorVal
Derive.CallError) a -> Deriver a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Run a parser against the current derive state.
parse :: Derive.Taggable d => Parser a -> Derive.PassedArgs d
    -> Derive.Deriver (Either Error a)
parse :: forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse Parser a
parser PassedArgs d
args = do
    [Track]
sub_tracks <- PassedArgs d -> Deriver [Track]
forall d. PassedArgs d -> Deriver [Track]
Sub.sub_tracks PassedArgs d
args
    Parser a -> State -> Either Error a
forall a. Parser a -> State -> Either Error a
run_parser Parser a
parser (State -> Either Error a)
-> (State -> State) -> State -> Either Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Track] -> State -> State
make_state [Track]
sub_tracks (State -> Either Error a)
-> Deriver State Error State -> Deriver (Either Error a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error State
forall st err. Deriver st err st
Derive.get
    where
    make_state :: [Track] -> State -> State
make_state [Track]
sub_tracks State
state = State
        { state_vals :: [Arg]
state_vals = (Val -> Arg) -> [Val] -> [Arg]
forall a b. (a -> b) -> [a] -> [b]
map Val -> Arg
LiteralArg (PassedArgs d -> [Val]
forall val. PassedArgs val -> [Val]
Derive.passed_vals PassedArgs d
args)
            [Arg] -> [Arg] -> [Arg]
forall a. [a] -> [a] -> [a]
++ (Track -> Arg) -> [Track] -> [Arg]
forall a b. (a -> b) -> [a] -> [b]
map Track -> Arg
SubTrack [Track]
sub_tracks
        , state_argnum :: Int
state_argnum = Int
0
        , state_call_name :: CallName
state_call_name = PassedArgs d -> CallName
forall val. PassedArgs val -> CallName
Derive.passed_call_name PassedArgs d
args
        , state_derive :: State
state_derive = State
state
        , state_context :: Context Tagged
state_context = Context d -> Context Tagged
forall a. Taggable a => Context a -> Context Tagged
Derive.tag_context (PassedArgs d -> Context d
forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args)
        }

-- | Like 'parse', but transformers don't get to see 'SubTrack' args.
parse_transformer :: Derive.Taggable d => Parser a -> Derive.PassedArgs d
    -> Derive.Deriver (Either Error a)
parse_transformer :: forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse_transformer Parser a
parser PassedArgs d
args =
    Parser a
-> Context Tagged -> CallName -> [Val] -> Deriver (Either Error a)
forall a.
Parser a
-> Context Tagged -> CallName -> [Val] -> Deriver (Either Error a)
parse_vals Parser a
parser (Context d -> Context Tagged
forall a. Taggable a => Context a -> Context Tagged
Derive.tag_context (PassedArgs d -> Context d
forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args))
        (PassedArgs d -> CallName
forall val. PassedArgs val -> CallName
Derive.passed_call_name PassedArgs d
args) (PassedArgs d -> [Val]
forall val. PassedArgs val -> [Val]
Derive.passed_vals PassedArgs d
args)

parse_vals :: Parser a -> Derive.Context Derive.Tagged -> CallName
    -> [DeriveT.Val] -> Derive.Deriver (Either Error a)
parse_vals :: forall a.
Parser a
-> Context Tagged -> CallName -> [Val] -> Deriver (Either Error a)
parse_vals Parser a
parser Context Tagged
ctx CallName
name [Val]
vals = Parser a -> State -> Either Error a
forall a. Parser a -> State -> Either Error a
run_parser Parser a
parser (State -> Either Error a)
-> (State -> State) -> State -> Either Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State
make_state (State -> Either Error a)
-> Deriver State Error State
-> Deriver State Error (Either Error a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error State
forall st err. Deriver st err st
Derive.get
    where
    make_state :: State -> State
make_state State
state = State
        { state_vals :: [Arg]
state_vals = (Val -> Arg) -> [Val] -> [Arg]
forall a b. (a -> b) -> [a] -> [b]
map Val -> Arg
LiteralArg [Val]
vals
        , state_argnum :: Int
state_argnum = Int
0
        , state_call_name :: CallName
state_call_name = CallName
name
        , state_derive :: State
state_derive = State
state
        , state_context :: Context Tagged
state_context = Context Tagged
ctx
        }

-- * parsers

-- | Parser for nullary calls.  Either use this with 'call' and 'callt', or use
-- 'call0' and 'call0t' as a shortcut.
no_args :: Parser ()
no_args :: Parser ()
no_args = () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | The argument is required to be present, and have the right type.
required :: forall a. Typecheck.Typecheck a => ArgName -> Doc.Doc -> Parser a
required :: forall a. Typecheck a => ArgName -> Doc -> Parser a
required ArgName
name = ArgName -> EnvironDefault -> Doc -> Parser a
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
required_env ArgName
name EnvironDefault
Derive.Prefixed

required_env :: forall a. Typecheck.Typecheck a => ArgName
    -> Derive.EnvironDefault -> Doc.Doc -> Parser a
required_env :: forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
required_env ArgName
name EnvironDefault
env_default Doc
doc = ArgDoc -> (State -> Either Error (State, a)) -> Parser a
forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc ((State -> Either Error (State, a)) -> Parser a)
-> (State -> Either Error (State, a)) -> Parser a
forall a b. (a -> b) -> a -> b
$ \State
state1 ->
    case EnvironDefault -> State -> ArgName -> Maybe (State, Arg)
get_val EnvironDefault
env_default State
state1 ArgName
name of
        Maybe (State, Arg)
Nothing -> Error -> Either Error (State, a)
forall a b. a -> Either a b
Left (Error -> Either Error (State, a))
-> Error -> Either Error (State, a)
forall a b. (a -> b) -> a -> b
$ Key -> Error
Derive.ArgError (Key -> Error) -> Key -> Error
forall a b. (a -> b) -> a -> b
$
            Key
"expected an argument at " Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> ArgName -> Key
forall a. Pretty a => a -> Key
pretty ArgName
name
        Just (State
state, Arg
arg) -> (State
state,) (a -> (State, a)) -> Either Error a -> Either Error (State, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state ArgDoc
arg_doc (State -> ErrorPlace
argnum_error State
state1) ArgName
name Arg
arg
    where
    expected :: Type
expected = Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    arg_doc :: ArgDoc
arg_doc = Derive.ArgDoc
        { arg_name :: ArgName
arg_name = ArgName
name
        , arg_type :: Type
arg_type = Type
expected
        , arg_parser :: ArgParser
arg_parser = ArgParser
Derive.Required
        , arg_environ_default :: EnvironDefault
arg_environ_default = EnvironDefault
env_default
        , arg_doc :: Doc
arg_doc = Doc
doc
        }


-- | The argument is not required to be present, but if it is, it has to have
-- either the right type or be VNotGiven.
defaulted :: forall a. (Typecheck.Typecheck a, ShowVal.ShowVal a) =>
    ArgName -> a -> Doc.Doc -> Parser a
defaulted :: forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
defaulted ArgName
name = ArgName -> EnvironDefault -> a -> Doc -> Parser a
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
defaulted_env ArgName
name EnvironDefault
Derive.Prefixed

defaulted_env :: forall a. (Typecheck.Typecheck a, ShowVal.ShowVal a) => ArgName
    -> Derive.EnvironDefault -> a -> Doc.Doc -> Parser a
defaulted_env :: forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
defaulted_env ArgName
name EnvironDefault
env_default a
deflt =
    ArgName -> EnvironDefault -> Either a Quoted -> Doc -> Parser a
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> Either a Quoted -> Doc -> Parser a
defaulted_env_ ArgName
name EnvironDefault
env_default (a -> Either a Quoted
forall a b. a -> Either a b
Left a
deflt)

-- | The defaulted value can be a 'DeriveT.Quoted', which will be evaluated
-- if needed.
defaulted_env_quoted :: forall a. (Typecheck.Typecheck a, ShowVal.ShowVal a) =>
    ArgName -> Derive.EnvironDefault -> DeriveT.Quoted -> Doc.Doc -> Parser a
defaulted_env_quoted :: forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> Quoted -> Doc -> Parser a
defaulted_env_quoted ArgName
name EnvironDefault
env_default Quoted
quoted =
    ArgName -> EnvironDefault -> Either a Quoted -> Doc -> Parser a
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> Either a Quoted -> Doc -> Parser a
defaulted_env_ ArgName
name EnvironDefault
env_default (Quoted -> Either a Quoted
forall a b. b -> Either a b
Right Quoted
quoted)

defaulted_env_ :: forall a. (Typecheck.Typecheck a, ShowVal.ShowVal a) =>
    ArgName -> Derive.EnvironDefault -> Either a DeriveT.Quoted -> Doc.Doc
    -> Parser a
defaulted_env_ :: forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> Either a Quoted -> Doc -> Parser a
defaulted_env_ ArgName
name EnvironDefault
env_default Either a Quoted
deflt_quoted Doc
doc = ArgDoc -> (State -> Either Error (State, a)) -> Parser a
forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc ((State -> Either Error (State, a)) -> Parser a)
-> (State -> Either Error (State, a)) -> Parser a
forall a b. (a -> b) -> a -> b
$ \State
state1 ->
    case EnvironDefault -> State -> ArgName -> Maybe (State, Arg)
get_val EnvironDefault
env_default State
state1 ArgName
name of
        Maybe (State, Arg)
Nothing -> State -> Either Error (State, a)
deflt State
state1
        Just (State
state, LiteralArg Val
DeriveT.VNotGiven) -> State -> Either Error (State, a)
deflt State
state
        Just (State
state, Arg
val) -> (State
state,) (a -> (State, a)) -> Either Error a -> Either Error (State, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state ArgDoc
arg_doc (State -> ErrorPlace
argnum_error State
state1) ArgName
name Arg
val
    where
    deflt :: State -> Either Error (State, a)
deflt State
state =
        ArgDoc
-> ErrorPlace
-> ArgName
-> State
-> Either a Quoted
-> Either Error (State, a)
forall a.
Typecheck a =>
ArgDoc
-> ErrorPlace
-> ArgName
-> State
-> Either a Quoted
-> Either Error (State, a)
eval_default ArgDoc
arg_doc (State -> ErrorPlace
argnum_error State
state) ArgName
name State
state Either a Quoted
deflt_quoted
    expected :: Type
expected = Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    arg_doc :: ArgDoc
arg_doc = Derive.ArgDoc
        { arg_name :: ArgName
arg_name = ArgName
name
        , arg_type :: Type
arg_type = Type
expected
        , arg_parser :: ArgParser
arg_parser = Key -> ArgParser
Derive.Defaulted (Key -> ArgParser) -> Key -> ArgParser
forall a b. (a -> b) -> a -> b
$
            (a -> Key) -> (Quoted -> Key) -> Either a Quoted -> Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Quoted -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Either a Quoted
deflt_quoted
        , arg_environ_default :: EnvironDefault
arg_environ_default = EnvironDefault
env_default
        , arg_doc :: Doc
arg_doc = Doc
doc
        }

-- | This is either 'required' or 'defaulted', depending on if there's a
-- default value.  Useful for making call variants with instrument-specific
-- defaults.
maybe_defaulted :: (Typecheck.Typecheck a, ShowVal.ShowVal a) =>
    ArgName -> Maybe a -> Doc.Doc -> Parser a
maybe_defaulted :: forall a.
(Typecheck a, ShowVal a) =>
ArgName -> Maybe a -> Doc -> Parser a
maybe_defaulted ArgName
name Maybe a
Nothing Doc
doc = ArgName -> Doc -> Parser a
forall a. Typecheck a => ArgName -> Doc -> Parser a
required ArgName
name Doc
doc
maybe_defaulted ArgName
name (Just a
deflt) Doc
doc = ArgName -> a -> Doc -> Parser a
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
defaulted ArgName
name a
deflt Doc
doc

-- | Eval a Quoted default value.
eval_default :: forall a. Typecheck.Typecheck a => Derive.ArgDoc
    -> Derive.ErrorPlace -> ArgName -> State -> Either a DeriveT.Quoted
    -> Either Error (State, a)
eval_default :: forall a.
Typecheck a =>
ArgDoc
-> ErrorPlace
-> ArgName
-> State
-> Either a Quoted
-> Either Error (State, a)
eval_default ArgDoc
_ ErrorPlace
_ ArgName
_ State
state (Left a
a) = (State, a) -> Either Error (State, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (State
state, a
a)
eval_default ArgDoc
arg_doc ErrorPlace
place ArgName
name State
state (Right Quoted
quoted) =
    case State -> Quoted -> Either Error Val
eval_quoted State
state Quoted
quoted of
        Left Error
err -> Error -> Either Error (State, a)
forall a b. a -> Either a b
Left (Error -> Either Error (State, a))
-> Error -> Either Error (State, a)
forall a b. (a -> b) -> a -> b
$ TypeErrorT -> Error
Derive.TypeError (TypeErrorT -> Error) -> TypeErrorT -> Error
forall a b. (a -> b) -> a -> b
$ Derive.TypeErrorT
            { error_place :: ErrorPlace
error_place = ErrorPlace
place
            , error_source :: EvalSource
error_source = Quoted -> EvalSource
Derive.Quoted Quoted
quoted
            , error_arg_name :: ArgName
error_arg_name = ArgName
name
            , error_expected :: Type
error_expected = Type
expected_type
            , error_received :: Maybe Val
error_received = Maybe Val
forall a. Maybe a
Nothing
            , error_derive :: Maybe Error
error_derive = Error -> Maybe Error
forall a. a -> Maybe a
Just Error
err
            }
        Right Val
val -> (State
state,) (a -> (State, a)) -> Either Error a -> Either Error (State, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state ArgDoc
arg_doc ErrorPlace
place ArgName
name (Val -> Arg
LiteralArg Val
val)
    where
    expected_type :: Type
expected_type = Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

-- | This is an argument which is not actually parsed from the argument list.
-- Instead it's looked up it the environ according to the normal defaulting
-- rules.
--
-- Of course, the call could just look in the environ itself, but this way it's
-- uniform and automatically documented.
environ :: forall a. (Typecheck.Typecheck a, ShowVal.ShowVal a) =>
    ArgName -> Derive.EnvironDefault
    -- ^ None doesn't make any sense, but, well, don't pass that then.
    -> a -> Doc.Doc -> Parser a
environ :: forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
environ ArgName
name EnvironDefault
env_default = ArgName -> EnvironDefault -> Either a Quoted -> Doc -> Parser a
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> Either a Quoted -> Doc -> Parser a
environ_ ArgName
name EnvironDefault
env_default (Either a Quoted -> Doc -> Parser a)
-> (a -> Either a Quoted) -> a -> Doc -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a Quoted
forall a b. a -> Either a b
Left

-- | A shortcut for an unprefixed environ key.
environ_key :: (Typecheck.Typecheck a, ShowVal.ShowVal a) =>
    Env.Key -> a -> Doc.Doc -> Parser a
environ_key :: forall a. (Typecheck a, ShowVal a) => Key -> a -> Doc -> Parser a
environ_key Key
key = ArgName -> EnvironDefault -> a -> Doc -> Parser a
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
environ (Key -> ArgName
Derive.ArgName Key
key) EnvironDefault
Unprefixed

-- | This is like 'environ', but the default is a 'DeriveT.Quoted', which
-- will be evaluated if needed.
environ_quoted :: forall a. (Typecheck.Typecheck a, ShowVal.ShowVal a) =>
    ArgName -> Derive.EnvironDefault -> DeriveT.Quoted -> Doc.Doc -> Parser a
environ_quoted :: forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> Quoted -> Doc -> Parser a
environ_quoted ArgName
name EnvironDefault
env_default = ArgName -> EnvironDefault -> Either a Quoted -> Doc -> Parser a
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> Either a Quoted -> Doc -> Parser a
environ_ ArgName
name EnvironDefault
env_default (Either a Quoted -> Doc -> Parser a)
-> (Quoted -> Either a Quoted) -> Quoted -> Doc -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quoted -> Either a Quoted
forall a b. b -> Either a b
Right

-- Internal function that handles both quoted and unquoted default.
environ_ :: forall a. (Typecheck.Typecheck a, ShowVal.ShowVal a) =>
    ArgName -> Derive.EnvironDefault
    -- ^ None doesn't make any sense, but, well, don't pass that then.
    -> Either a DeriveT.Quoted -> Doc.Doc -> Parser a
environ_ :: forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> Either a Quoted -> Doc -> Parser a
environ_ ArgName
name EnvironDefault
env_default Either a Quoted
quoted Doc
doc = ArgDoc -> (State -> Either Error (State, a)) -> Parser a
forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc ((State -> Either Error (State, a)) -> Parser a)
-> (State -> Either Error (State, a)) -> Parser a
forall a b. (a -> b) -> a -> b
$ \State
state ->
    case EnvironDefault -> State -> ArgName -> Maybe Val
lookup_default EnvironDefault
env_default State
state ArgName
name of
        Maybe Val
Nothing -> State -> Either Error (State, a)
deflt State
state
        Just Val
val -> (State
state,) (a -> (State, a)) -> Either Error a -> Either Error (State, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state ArgDoc
arg_doc (State -> ArgName -> ErrorPlace
environ_error State
state ArgName
name) ArgName
name
                (Val -> Arg
LiteralArg Val
val)
    where
    deflt :: State -> Either Error (State, a)
deflt State
state = ArgDoc
-> ErrorPlace
-> ArgName
-> State
-> Either a Quoted
-> Either Error (State, a)
forall a.
Typecheck a =>
ArgDoc
-> ErrorPlace
-> ArgName
-> State
-> Either a Quoted
-> Either Error (State, a)
eval_default ArgDoc
arg_doc (State -> ErrorPlace
argnum_error State
state) ArgName
name State
state Either a Quoted
quoted
    expected :: Type
expected = Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    arg_doc :: ArgDoc
arg_doc = Derive.ArgDoc
        { arg_name :: ArgName
arg_name = ArgName
name
        , arg_type :: Type
arg_type = Type
expected
        , arg_parser :: ArgParser
arg_parser = Maybe Key -> ArgParser
Derive.Environ (Maybe Key -> ArgParser) -> Maybe Key -> ArgParser
forall a b. (a -> b) -> a -> b
$ Key -> Maybe Key
forall a. a -> Maybe a
Just (Key -> Maybe Key) -> Key -> Maybe Key
forall a b. (a -> b) -> a -> b
$
            (a -> Key) -> (Quoted -> Key) -> Either a Quoted -> Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Quoted -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Either a Quoted
quoted
        , arg_environ_default :: EnvironDefault
arg_environ_default = EnvironDefault
env_default
        , arg_doc :: Doc
arg_doc = Doc
doc
        }

-- | This is like 'environ', but without a default.
required_environ :: forall a. Typecheck.Typecheck a =>
    ArgName -> Derive.EnvironDefault -> Doc.Doc -> Parser a
required_environ :: forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
required_environ ArgName
name EnvironDefault
env_default Doc
doc = ArgDoc -> (State -> Either Error (State, a)) -> Parser a
forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc ((State -> Either Error (State, a)) -> Parser a)
-> (State -> Either Error (State, a)) -> Parser a
forall a b. (a -> b) -> a -> b
$ \State
state ->
    case EnvironDefault -> State -> ArgName -> Maybe Val
lookup_default EnvironDefault
env_default State
state ArgName
name of
        Maybe Val
Nothing -> Error -> Either Error (State, a)
forall a b. a -> Either a b
Left (Error -> Either Error (State, a))
-> Error -> Either Error (State, a)
forall a b. (a -> b) -> a -> b
$ TypeErrorT -> Error
Derive.TypeError (TypeErrorT -> Error) -> TypeErrorT -> Error
forall a b. (a -> b) -> a -> b
$ Derive.TypeErrorT
            { error_place :: ErrorPlace
error_place = State -> ArgName -> ErrorPlace
environ_error State
state ArgName
name
            , error_source :: EvalSource
error_source = EvalSource
Derive.Literal
            , error_arg_name :: ArgName
error_arg_name = ArgName
name
            , error_expected :: Type
error_expected = Type
expected
            , error_received :: Maybe Val
error_received = Maybe Val
forall a. Maybe a
Nothing
            , error_derive :: Maybe Error
error_derive = Maybe Error
forall a. Maybe a
Nothing
            }
        Just Val
val -> (State
state,) (a -> (State, a)) -> Either Error a -> Either Error (State, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state ArgDoc
arg_doc (State -> ArgName -> ErrorPlace
environ_error State
state ArgName
name) ArgName
name
                (Val -> Arg
LiteralArg Val
val)
    where
    expected :: Type
expected = Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    arg_doc :: ArgDoc
arg_doc = Derive.ArgDoc
        { arg_name :: ArgName
arg_name = ArgName
name
        , arg_type :: Type
Derive.arg_type = Type
expected
        , arg_parser :: ArgParser
Derive.arg_parser = Maybe Key -> ArgParser
Derive.Environ Maybe Key
forall a. Maybe a
Nothing
        , arg_environ_default :: EnvironDefault
Derive.arg_environ_default = EnvironDefault
env_default
        , arg_doc :: Doc
arg_doc = Doc
doc
        }

required_environ_key :: Typecheck.Typecheck a => Env.Key -> Doc.Doc -> Parser a
required_environ_key :: forall a. Typecheck a => Key -> Doc -> Parser a
required_environ_key Key
key = ArgName -> EnvironDefault -> Doc -> Parser a
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
required_environ (Key -> ArgName
Derive.ArgName Key
key) EnvironDefault
Unprefixed

-- | This is like 'defaulted', but if the argument is the wrong type return
-- the default instead of failing.  It's mostly useful with 'many' or 'many1',
-- where you can distinguish the arguments by type.
optional :: forall a. (Typecheck.Typecheck a, ShowVal.ShowVal a) => ArgName -> a
    -> Doc.Doc -> Parser a
optional :: forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
optional ArgName
name = ArgName -> EnvironDefault -> a -> Doc -> Parser a
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
optional_env ArgName
name EnvironDefault
Derive.Prefixed

optional_env :: forall a. (Typecheck.Typecheck a, ShowVal.ShowVal a) =>
    ArgName -> Derive.EnvironDefault -> a -> Doc.Doc -> Parser a
optional_env :: forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
optional_env ArgName
name EnvironDefault
env_default a
deflt Doc
doc = ArgDoc -> (State -> Either Error (State, a)) -> Parser a
forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc ((State -> Either Error (State, a)) -> Parser a)
-> (State -> Either Error (State, a)) -> Parser a
forall a b. (a -> b) -> a -> b
$ \State
state1 ->
    case EnvironDefault -> State -> ArgName -> Maybe (State, Arg)
get_val EnvironDefault
env_default State
state1 ArgName
name of
        Maybe (State, Arg)
Nothing -> (State, a) -> Either Error (State, a)
forall a b. b -> Either a b
Right (State
state1, a
deflt)
        Just (State
state, LiteralArg Val
DeriveT.VNotGiven) -> (State, a) -> Either Error (State, a)
forall a b. b -> Either a b
Right (State
state, a
deflt)
        Just (State
state, Arg
arg) ->
            case State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state ArgDoc
arg_doc (State -> ErrorPlace
argnum_error State
state1) ArgName
name Arg
arg of
                Right a
a -> (State, a) -> Either Error (State, a)
forall a b. b -> Either a b
Right (State
state, a
a)
                Left (Derive.TypeError {}) ->
                    case EnvironDefault -> State -> ArgName -> Maybe Val
lookup_default EnvironDefault
env_default State
state ArgName
name of
                        Maybe Val
Nothing -> (State, a) -> Either Error (State, a)
forall a b. b -> Either a b
Right (State
state, a
deflt)
                        Just Val
arg -> (State
state,) (a -> (State, a)) -> Either Error a -> Either Error (State, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state ArgDoc
arg_doc (State -> ErrorPlace
argnum_error State
state1)
                                ArgName
name (Val -> Arg
LiteralArg Val
arg)
                Left Error
err -> Error -> Either Error (State, a)
forall a b. a -> Either a b
Left Error
err
    where
    expected :: Type
expected = Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    arg_doc :: ArgDoc
arg_doc = Derive.ArgDoc
        { arg_name :: ArgName
arg_name = ArgName
name
        , arg_type :: Type
arg_type = Type
expected
        , arg_parser :: ArgParser
arg_parser = Key -> ArgParser
Derive.Optional (a -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val a
deflt)
        , arg_environ_default :: EnvironDefault
arg_environ_default = EnvironDefault
env_default
        , arg_doc :: Doc
arg_doc = Doc
doc
        }

-- | Collect the rest of the arguments.
many :: forall a. Typecheck.Typecheck a => ArgName -> Doc.Doc -> Parser [a]
many :: forall a. Typecheck a => ArgName -> Doc -> Parser [a]
many ArgName
name Doc
doc = ArgDoc -> (State -> Either Error (State, [a])) -> Parser [a]
forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc ((State -> Either Error (State, [a])) -> Parser [a])
-> (State -> Either Error (State, [a])) -> Parser [a]
forall a b. (a -> b) -> a -> b
$ \State
state -> do
    [a]
vals <- ((Int, Arg) -> Either Error a) -> [(Int, Arg)] -> Either Error [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (State -> (Int, Arg) -> Either Error a
forall {a}. Typecheck a => State -> (Int, Arg) -> Either Error a
typecheck State
state)
        ([Int] -> [Arg] -> [(Int, Arg)]
forall a b. [a] -> [b] -> [(a, b)]
zip [State -> Int
state_argnum State
state ..] (State -> [Arg]
state_vals State
state))
    let state2 :: State
state2 = Int -> State -> State
increment_argnum ([Arg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (State -> [Arg]
state_vals State
state)) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$
            State
state { state_vals :: [Arg]
state_vals = []}
    (State, [a]) -> Either Error (State, [a])
forall a b. b -> Either a b
Right (State
state2, [a]
vals)
    where
    typecheck :: State -> (Int, Arg) -> Either Error a
typecheck State
state (Int
argnum, Arg
arg) =
        State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state ArgDoc
arg_doc (Int -> ErrorPlace
Derive.TypeErrorArg Int
argnum) ArgName
name Arg
arg
    expected :: Type
expected = Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    arg_doc :: ArgDoc
arg_doc = Derive.ArgDoc
        { arg_name :: ArgName
arg_name = ArgName
name
        , arg_type :: Type
arg_type = Type
expected
        , arg_parser :: ArgParser
arg_parser = ArgParser
Derive.Many
        , arg_environ_default :: EnvironDefault
arg_environ_default = EnvironDefault
Derive.None
        , arg_doc :: Doc
arg_doc = Doc
doc
        }

-- | 'many' specialized to Vals, to avoid a type annotation.
many_vals :: ArgName -> Doc.Doc -> Parser [DeriveT.Val]
many_vals :: ArgName -> Doc -> Parser [Val]
many_vals ArgName
name Doc
doc = ArgName -> Doc -> Parser [Val]
forall a. Typecheck a => ArgName -> Doc -> Parser [a]
many ArgName
name Doc
doc

-- | Collect the rest of the arguments, but there must be at least one.
many1 :: forall a. Typecheck.Typecheck a => ArgName -> Doc.Doc
    -> Parser (NonEmpty a)
many1 :: forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
many1 ArgName
name Doc
doc = ArgName -> Parser [a] -> Parser (NonEmpty a)
forall a. ArgName -> Parser [a] -> Parser (NonEmpty a)
non_empty ArgName
name (Parser [a] -> Parser (NonEmpty a))
-> Parser [a] -> Parser (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ ArgName -> Doc -> Parser [a]
forall a. Typecheck a => ArgName -> Doc -> Parser [a]
many ArgName
name Doc
doc

-- | Collect the rest of the arguments, but expect a even number of them and
-- pair them up.
many_pairs :: forall a b. (Typecheck.Typecheck a,  Typecheck.Typecheck b) =>
    ArgName -> Doc.Doc -> Parser [(a, b)]
many_pairs :: forall a b.
(Typecheck a, Typecheck b) =>
ArgName -> Doc -> Parser [(a, b)]
many_pairs ArgName
name Doc
doc = ArgDoc
-> (State -> Either Error (State, [(a, b)])) -> Parser [(a, b)]
forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser (Type -> ArgDoc
arg_doc Type
expected) ((State -> Either Error (State, [(a, b)])) -> Parser [(a, b)])
-> (State -> Either Error (State, [(a, b)])) -> Parser [(a, b)]
forall a b. (a -> b) -> a -> b
$ \State
state -> do
    let vals :: [Arg]
vals = State -> [Arg]
state_vals State
state
    Bool -> Either Error () -> Either Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
forall a. Integral a => a -> Bool
odd ([Arg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg]
vals)) (Either Error () -> Either Error ())
-> Either Error () -> Either Error ()
forall a b. (a -> b) -> a -> b
$
        Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ Key -> Error
Derive.ArgError (Key -> Error) -> Key -> Error
forall a b. (a -> b) -> a -> b
$ Key
"many_pairs requires an even argument length: "
            Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Int -> Key
forall a. Show a => a -> Key
showt ([Arg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg]
vals)
    [(a, b)]
vals <- ((Int, (Arg, Arg)) -> Either Error (a, b))
-> [(Int, (Arg, Arg))] -> Either Error [(a, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (State -> (Int, (Arg, Arg)) -> Either Error (a, b)
forall {a} {a}.
(Typecheck a, Typecheck a) =>
State -> (Int, (Arg, Arg)) -> Either Error (a, a)
typecheck State
state) ([(Int, (Arg, Arg))] -> Either Error [(a, b)])
-> [(Int, (Arg, Arg))] -> Either Error [(a, b)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [(Arg, Arg)] -> [(Int, (Arg, Arg))]
forall a b. [a] -> [b] -> [(a, b)]
zip [State -> Int
state_argnum State
state ..] ([Arg] -> [(Arg, Arg)]
forall {b}. [b] -> [(b, b)]
pairs [Arg]
vals)
    let state2 :: State
state2 = Int -> State -> State
increment_argnum ([(a, b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, b)]
vals) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
state { state_vals :: [Arg]
state_vals = [] }
    (State, [(a, b)]) -> Either Error (State, [(a, b)])
forall a b. b -> Either a b
Right (State
state2, [(a, b)]
vals)
    where
    typecheck :: State -> (Int, (Arg, Arg)) -> Either Error (a, a)
typecheck State
state (Int
argnum, (Arg
val1, Arg
val2)) = (,)
        (a -> a -> (a, a)) -> Either Error a -> Either Error (a -> (a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state (Type -> ArgDoc
arg_doc (Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)))
            (Int -> ErrorPlace
Derive.TypeErrorArg (Int
argnum Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)) ArgName
name Arg
val1
        Either Error (a -> (a, a)) -> Either Error a -> Either Error (a, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state (Type -> ArgDoc
arg_doc (Proxy b -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy b
forall {k} (t :: k). Proxy t
Proxy :: Proxy b)))
            (Int -> ErrorPlace
Derive.TypeErrorArg (Int
argnum Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) ArgName
name Arg
val2
    expected :: Type
expected = Type -> Type -> Type
ValType.TPair (Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))
        (Proxy b -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy b
forall {k} (t :: k). Proxy t
Proxy :: Proxy b))
    arg_doc :: Type -> ArgDoc
arg_doc Type
expected = Derive.ArgDoc
        { arg_name :: ArgName
arg_name = ArgName
name
        , arg_type :: Type
arg_type = Type
expected
        , arg_parser :: ArgParser
arg_parser = ArgParser
Derive.Many
        , arg_environ_default :: EnvironDefault
arg_environ_default = EnvironDefault
Derive.None
        , arg_doc :: Doc
arg_doc = Doc
doc
        }
    pairs :: [b] -> [(b, b)]
pairs (b
a : b
b : [b]
xs) = (b
a, b
b) (b, b) -> [(b, b)] -> [(b, b)]
forall a. a -> [a] -> [a]
: [b] -> [(b, b)]
pairs [b]
xs
    pairs [b]
_ = []

-- | Like 'many_pairs', but require at least one pair.
many1_pairs :: forall a b. (Typecheck.Typecheck a,  Typecheck.Typecheck b) =>
    ArgName -> Doc.Doc -> Parser (NonEmpty (a, b))
many1_pairs :: forall a b.
(Typecheck a, Typecheck b) =>
ArgName -> Doc -> Parser (NonEmpty (a, b))
many1_pairs ArgName
name Doc
doc = ArgName -> Parser [(a, b)] -> Parser (NonEmpty (a, b))
forall a. ArgName -> Parser [a] -> Parser (NonEmpty a)
non_empty ArgName
name (Parser [(a, b)] -> Parser (NonEmpty (a, b)))
-> Parser [(a, b)] -> Parser (NonEmpty (a, b))
forall a b. (a -> b) -> a -> b
$ ArgName -> Doc -> Parser [(a, b)]
forall a b.
(Typecheck a, Typecheck b) =>
ArgName -> Doc -> Parser [(a, b)]
many_pairs ArgName
name Doc
doc

-- | Modify a 'many' parser to require at least one thing.
non_empty :: ArgName -> Parser [a] -> Parser (NonEmpty a)
non_empty :: forall a. ArgName -> Parser [a] -> Parser (NonEmpty a)
non_empty ArgName
name (Parser Docs
docs State -> Either Error (State, [a])
p) =
    Docs
-> (State -> Either Error (State, NonEmpty a))
-> Parser (NonEmpty a)
forall a. Docs -> (State -> Either Error (State, a)) -> Parser a
Parser ((ArgDoc -> ArgDoc) -> Docs -> Docs
forall a b. (a -> b) -> [a] -> [b]
map (\ArgDoc
d -> ArgDoc
d { arg_parser :: ArgParser
Derive.arg_parser = ArgParser
Derive.Many1 }) Docs
docs) State -> Either Error (State, NonEmpty a)
convert
    where
    convert :: State -> Either Error (State, NonEmpty a)
convert State
state = case State -> Either Error (State, [a])
p State
state of
        Left Error
err -> Error -> Either Error (State, NonEmpty a)
forall a b. a -> Either a b
Left Error
err
        Right (State
_, []) -> Error -> Either Error (State, NonEmpty a)
forall a b. a -> Either a b
Left (Error -> Either Error (State, NonEmpty a))
-> Error -> Either Error (State, NonEmpty a)
forall a b. (a -> b) -> a -> b
$ Key -> Error
Derive.ArgError (Key -> Error) -> Key -> Error
forall a b. (a -> b) -> a -> b
$
            Key
"arg requires at least one value: " Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> ArgName -> Key
forall a. Pretty a => a -> Key
pretty ArgName
name
        Right (State
state, a
x : [a]
xs) -> (State, NonEmpty a) -> Either Error (State, NonEmpty a)
forall a b. b -> Either a b
Right (State
state, a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)

-- | Require one Val for each ArgDoc given, but otherwise do no typechecking.
required_vals :: [Derive.ArgDoc] -> Parser [Arg]
required_vals :: Docs -> Parser [Arg]
required_vals Docs
docs = Docs -> (State -> Either Error (State, [Arg])) -> Parser [Arg]
forall a. Docs -> (State -> Either Error (State, a)) -> Parser a
Parser Docs
docs State -> Either Error (State, [Arg])
forall {a}. State -> Either a (State, [Arg])
parser
    where
    -- I don't check the number of arguments because this is used for call
    -- macros, and I need to give the sub-call a chance to default its args.
    parser :: State -> Either a (State, [Arg])
parser State
state = (State, [Arg]) -> Either a (State, [Arg])
forall a b. b -> Either a b
Right (State
state2, [Arg]
vals)
        where
        ([Arg]
vals, [Arg]
rest) = Int -> [Arg] -> ([Arg], [Arg])
forall a. Int -> [a] -> ([a], [a])
splitAt (Docs -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Docs
docs) (State -> [Arg]
state_vals State
state)
        state2 :: State
state2 = Int -> State -> State
increment_argnum ([Arg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg]
vals) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ State
state { state_vals :: [Arg]
state_vals = [Arg]
rest}

argnum_error :: State -> Derive.ErrorPlace
argnum_error :: State -> ErrorPlace
argnum_error = Int -> ErrorPlace
Derive.TypeErrorArg (Int -> ErrorPlace) -> (State -> Int) -> State -> ErrorPlace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Int
state_argnum

environ_error :: State -> ArgName -> Derive.ErrorPlace
environ_error :: State -> ArgName -> ErrorPlace
environ_error State
state ArgName
name =
    Key -> ErrorPlace
Derive.TypeErrorEnviron (CallName -> ArgName -> Key
prefixed_environ (State -> CallName
state_call_name State
state) ArgName
name)

increment_argnum :: Int -> State -> State
increment_argnum :: Int -> State -> State
increment_argnum Int
n State
state = State
state { state_argnum :: Int
state_argnum = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ State -> Int
state_argnum State
state }

-- ** defaults

-- | The argument's value is taken from the given signal, with the given
-- default.  If the value isn't given, the default is Untyped.
control :: ScoreT.Control -> Signal.Y -> DeriveT.ControlRef
control :: Control -> Y -> ControlRef
control Control
name Y
deflt = Control -> Y -> Type -> ControlRef
typed_control Control
name Y
deflt Type
ScoreT.Untyped

-- | Like 'control', but the default can have a type.
typed_control :: ScoreT.Control -> Signal.Y -> ScoreT.Type
    -> DeriveT.ControlRef
typed_control :: Control -> Y -> Type -> ControlRef
typed_control Control
name Y
deflt Type
typ =
    Control -> Typed Control -> ControlRef
forall control val. control -> val -> Ref control val
DeriveT.DefaultedControl Control
name (Type -> Control -> Typed Control
forall a. Type -> a -> Typed a
ScoreT.Typed Type
typ (Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
deflt))

required_control :: ScoreT.Control -> DeriveT.ControlRef
required_control :: Control -> ControlRef
required_control = Control -> ControlRef
forall control val. control -> Ref control val
DeriveT.LiteralControl

-- | Pitch signal.  There's no default because that would depend on the scale.
pitch :: ScoreT.PControl -> DeriveT.PControlRef
pitch :: PControl -> PControlRef
pitch = PControl -> PControlRef
forall control val. control -> Ref control val
DeriveT.LiteralControl

-- ** util

get_val :: Derive.EnvironDefault -> State -> ArgName -> Maybe (State, Arg)
get_val :: EnvironDefault -> State -> ArgName -> Maybe (State, Arg)
get_val EnvironDefault
env_default State
state ArgName
name = case State -> [Arg]
state_vals State
state of
    Arg
v : [Arg]
vs -> (State, Arg) -> Maybe (State, Arg)
forall a. a -> Maybe a
Just
        ( State
next { state_vals :: [Arg]
state_vals = [Arg]
vs }
        , case Arg
v of
            LiteralArg Val
DeriveT.VNotGiven ->
                Val -> Arg
LiteralArg (Val -> Arg) -> Val -> Arg
forall a b. (a -> b) -> a -> b
$ Val -> Maybe Val -> Val
forall a. a -> Maybe a -> a
fromMaybe Val
DeriveT.VNotGiven (Maybe Val -> Val) -> Maybe Val -> Val
forall a b. (a -> b) -> a -> b
$
                    EnvironDefault -> State -> ArgName -> Maybe Val
lookup_default EnvironDefault
env_default State
state ArgName
name
            Arg
_ -> Arg
v
        )
    [] -> (State
next,) (Arg -> (State, Arg)) -> (Val -> Arg) -> Val -> (State, Arg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Arg
LiteralArg (Val -> (State, Arg)) -> Maybe Val -> Maybe (State, Arg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnvironDefault -> State -> ArgName -> Maybe Val
lookup_default EnvironDefault
env_default State
state ArgName
name
    where next :: State
next = Int -> State -> State
increment_argnum Int
1 State
state

check_arg :: forall a. Typecheck.Typecheck a => State -> Derive.ArgDoc
    -> Derive.ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg :: forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state ArgDoc
arg_doc ErrorPlace
place ArgName
name Arg
arg = case Arg
arg of
    LiteralArg Val
val -> case State -> Val -> Either Error (Maybe a)
forall a. Typecheck a => State -> Val -> Either Error (Maybe a)
from_val State
state Val
val of
        Left Error
err -> Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a) -> Error -> Either Error a
forall a b. (a -> b) -> a -> b
$ EvalSource -> Maybe Val -> Maybe Error -> Error
type_error EvalSource
Derive.Literal (Val -> Maybe Val
forall a. a -> Maybe a
Just Val
val) (Error -> Maybe Error
forall a. a -> Maybe a
Just Error
err)
        Right (Just a
a) -> a -> Either Error a
forall a b. b -> Either a b
Right a
a
        Right Maybe a
Nothing -> case Val
val of
            -- 'val' failed to typecheck, so try to coerce a Quoted to a new
            -- qval and typecheck that.
            DeriveT.VQuoted Quoted
quoted -> do
                let source :: EvalSource
source = Quoted -> EvalSource
Derive.Quoted Quoted
quoted
                Val
qval <- EvalSource -> Val -> Either Error Val -> Either Error Val
forall {p :: * -> * -> *} {c}.
Bifunctor p =>
EvalSource -> Val -> p Error c -> p Error c
promote_error EvalSource
source Val
val (Either Error Val -> Either Error Val)
-> Either Error Val -> Either Error Val
forall a b. (a -> b) -> a -> b
$ State -> Quoted -> Either Error Val
eval_quoted State
state Quoted
quoted
                Maybe a
maybe_a <- EvalSource
-> Val -> Either Error (Maybe a) -> Either Error (Maybe a)
forall {p :: * -> * -> *} {c}.
Bifunctor p =>
EvalSource -> Val -> p Error c -> p Error c
promote_error EvalSource
source Val
qval (Either Error (Maybe a) -> Either Error (Maybe a))
-> Either Error (Maybe a) -> Either Error (Maybe a)
forall a b. (a -> b) -> a -> b
$ State -> Val -> Either Error (Maybe a)
forall a. Typecheck a => State -> Val -> Either Error (Maybe a)
from_val State
state Val
qval
                case Maybe a
maybe_a of
                    Just a
a -> a -> Either Error a
forall a b. b -> Either a b
Right a
a
                    Maybe a
Nothing -> Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a) -> Error -> Either Error a
forall a b. (a -> b) -> a -> b
$ EvalSource -> Maybe Val -> Maybe Error -> Error
type_error EvalSource
source (Val -> Maybe Val
forall a. a -> Maybe a
Just Val
qval) Maybe Error
forall a. Maybe a
Nothing
            Val
_ -> Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a) -> Error -> Either Error a
forall a b. (a -> b) -> a -> b
$ EvalSource -> Maybe Val -> Maybe Error -> Error
type_error EvalSource
Derive.Literal (Val -> Maybe Val
forall a. a -> Maybe a
Just Val
val) Maybe Error
forall a. Maybe a
Nothing
    SubTrack Track
track -> case Track -> Maybe a
forall a. Typecheck a => Track -> Maybe a
Typecheck.from_subtrack Track
track of
        Just a
a -> a -> Either Error a
forall a b. b -> Either a b
Right a
a
        Maybe a
Nothing -> Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a) -> Error -> Either Error a
forall a b. (a -> b) -> a -> b
$
            EvalSource -> Maybe Val -> Maybe Error -> Error
type_error (Either Key TrackId -> EvalSource
Derive.SubTrack (Track -> Either Key TrackId
SubT._source Track
track)) Maybe Val
forall a. Maybe a
Nothing Maybe Error
forall a. Maybe a
Nothing
    where
    promote_error :: EvalSource -> Val -> p Error c -> p Error c
promote_error EvalSource
source Val
val = (Error -> Error) -> p Error c -> p Error c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (EvalSource -> Maybe Val -> Maybe Error -> Error
type_error EvalSource
source (Val -> Maybe Val
forall a. a -> Maybe a
Just Val
val) (Maybe Error -> Error) -> (Error -> Maybe Error) -> Error -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Maybe Error
forall a. a -> Maybe a
Just)
    type_error :: EvalSource -> Maybe Val -> Maybe Error -> Error
type_error EvalSource
source Maybe Val
maybe_val Maybe Error
derive = TypeErrorT -> Error
Derive.TypeError (TypeErrorT -> Error) -> TypeErrorT -> Error
forall a b. (a -> b) -> a -> b
$ Derive.TypeErrorT
        { error_place :: ErrorPlace
error_place = ErrorPlace
place
        , error_source :: EvalSource
error_source = EvalSource
source
        , error_arg_name :: ArgName
error_arg_name = ArgName
name
        , error_expected :: Type
error_expected = ArgDoc -> Type
Derive.arg_type ArgDoc
arg_doc
        , error_received :: Maybe Val
error_received = Maybe Val
maybe_val
        , error_derive :: Maybe Error
error_derive = Maybe Error
derive
        }
    -- expected = Typecheck.to_type (Proxy :: Proxy a)

-- | Typecheck a Val, evaluating if necessary.
from_val :: Typecheck.Typecheck a => State -> DeriveT.Val
    -> Either Derive.Error (Maybe a)
from_val :: forall a. Typecheck a => State -> Val -> Either Error (Maybe a)
from_val State
state Val
val = State -> Deriver (Maybe a) -> Either Error (Maybe a)
forall a. State -> Deriver a -> Either Error a
run State
state (Deriver (Maybe a) -> Either Error (Maybe a))
-> Deriver (Maybe a) -> Either Error (Maybe a)
forall a b. (a -> b) -> a -> b
$ case Val -> Checked a
forall a. Typecheck a => Val -> Checked a
Typecheck.from_val Val
val of
    Typecheck.Val Result a
result -> Maybe a -> Deriver (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Deriver (Maybe a)) -> Maybe a -> Deriver (Maybe a)
forall a b. (a -> b) -> a -> b
$ case Result a
result of
        Result a
Typecheck.Failure -> Maybe a
forall a. Maybe a
Nothing
        Typecheck.Success a
a -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
        Typecheck.Derive Context Tagged -> a
deriver -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Context Tagged -> a
deriver (State -> Context Tagged
state_context State
state)
    Typecheck.Eval RealTime -> Deriver (Maybe a)
deriver -> RealTime -> Deriver (Maybe a)
deriver (RealTime -> Deriver (Maybe a))
-> Deriver State Error RealTime -> Deriver (Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScoreTime -> Deriver State Error RealTime
Derive.score_to_real ScoreTime
start
    where start :: ScoreTime
start = Event -> ScoreTime
Event.start (Event -> ScoreTime) -> Event -> ScoreTime
forall a b. (a -> b) -> a -> b
$ Context Tagged -> Event
forall val. Context val -> Event
Derive.ctx_event (Context Tagged -> Event) -> Context Tagged -> Event
forall a b. (a -> b) -> a -> b
$ State -> Context Tagged
state_context State
state

-- This can't be defined in Derive.Typecheck, because it uses Eval, and Eval
-- imports Typecheck.  It could be in Eval, but here it's closer to 'from_val',
-- which uses its result.
instance Typecheck.Typecheck Derive.NoteDeriver where
    from_val :: Val -> Checked NoteDeriver
from_val = Val -> Checked NoteDeriver
forall d. CallableExpr d => Val -> Checked (Deriver (Stream d))
quoted_to_deriver
    to_type :: Proxy NoteDeriver -> Type
to_type Proxy NoteDeriver
_ = Key -> Type
ValType.TDeriver Key
"note"
    -- This means that a subtrack can coerce to a deriver arg, in addition to
    -- a SubT.Track.
    from_subtrack :: Track -> Maybe NoteDeriver
from_subtrack = NoteDeriver -> Maybe NoteDeriver
forall a. a -> Maybe a
Just (NoteDeriver -> Maybe NoteDeriver)
-> (Track -> NoteDeriver) -> Track -> Maybe NoteDeriver
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> NoteDeriver
Sub.derive ([Event] -> NoteDeriver)
-> (Track -> [Event]) -> Track -> NoteDeriver
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> [Event]
SubT._events
instance Typecheck.Typecheck Derive.ControlDeriver where
    from_val :: Val -> Checked ControlDeriver
from_val = Val -> Checked ControlDeriver
forall d. CallableExpr d => Val -> Checked (Deriver (Stream d))
quoted_to_deriver
    to_type :: Proxy ControlDeriver -> Type
to_type Proxy ControlDeriver
_ = Key -> Type
ValType.TDeriver Key
"control"
instance Typecheck.Typecheck Derive.PitchDeriver where
    from_val :: Val -> Checked PitchDeriver
from_val = Val -> Checked PitchDeriver
forall d. CallableExpr d => Val -> Checked (Deriver (Stream d))
quoted_to_deriver
    to_type :: Proxy PitchDeriver -> Type
to_type Proxy PitchDeriver
_ = Key -> Type
ValType.TDeriver Key
"pitch"

quoted_to_deriver :: Derive.CallableExpr d => DeriveT.Val
    -> Typecheck.Checked (Derive.Deriver (Stream.Stream d))
quoted_to_deriver :: forall d. CallableExpr d => Val -> Checked (Deriver (Stream d))
quoted_to_deriver Val
val = case Val -> Maybe Quoted
as_quoted Val
val of
    Just Quoted
quoted -> Result (Deriver (Stream d)) -> Checked (Deriver (Stream d))
forall a. Result a -> Checked a
Typecheck.Val (Result (Deriver (Stream d)) -> Checked (Deriver (Stream d)))
-> Result (Deriver (Stream d)) -> Checked (Deriver (Stream d))
forall a b. (a -> b) -> a -> b
$ (Context Tagged -> Deriver (Stream d))
-> Result (Deriver (Stream d))
forall a. (Context Tagged -> a) -> Result a
Typecheck.Derive ((Context Tagged -> Deriver (Stream d))
 -> Result (Deriver (Stream d)))
-> (Context Tagged -> Deriver (Stream d))
-> Result (Deriver (Stream d))
forall a b. (a -> b) -> a -> b
$
        \Context Tagged
ctx -> Context d -> Quoted -> Deriver (Stream d)
forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (Context Tagged -> Context d
forall a. Taggable a => Context Tagged -> Context a
Derive.untag_context Context Tagged
ctx) Quoted
quoted
    Maybe Quoted
Nothing -> Checked (Deriver (Stream d))
forall a. Checked a
Typecheck.failure

as_quoted :: DeriveT.Val -> Maybe DeriveT.Quoted
as_quoted :: Val -> Maybe Quoted
as_quoted = \case
    DeriveT.VQuoted Quoted
a -> Quoted -> Maybe Quoted
forall a. a -> Maybe a
Just Quoted
a
    DeriveT.VStr (Expr.Str Key
sym) ->
        Quoted -> Maybe Quoted
forall a. a -> Maybe a
Just (Quoted -> Maybe Quoted) -> Quoted -> Maybe Quoted
forall a b. (a -> b) -> a -> b
$ Expr -> Quoted
DeriveT.Quoted (Expr -> Quoted) -> Expr -> Quoted
forall a b. (a -> b) -> a -> b
$ Symbol -> [Term Val] -> Call Val
forall val. Symbol -> [Term val] -> Call val
Expr.Call (Key -> Symbol
Expr.Symbol Key
sym) [] Call Val -> [Call Val] -> Expr
forall a. a -> [a] -> NonEmpty a
:| []
    Val
_ -> Maybe Quoted
forall a. Maybe a
Nothing

run :: State -> Derive.Deriver a -> Either Derive.Error a
run :: forall a. State -> Deriver a -> Either Error a
run State
state Deriver a
deriver = Either Error a
result
    where (Either Error a
result, State
_state, [Msg]
_logs) = State -> Deriver a -> (Either Error a, State, [Msg])
forall st err a. st -> Deriver st err a -> RunResult st err a
Derive.run (State -> State
state_derive State
state) Deriver a
deriver

eval_quoted :: State -> DeriveT.Quoted -> Either Derive.Error DeriveT.Val
eval_quoted :: State -> Quoted -> Either Error Val
eval_quoted State
state (DeriveT.Quoted Expr
expr) = Either Error Val
result
    where
    (Either Error Val
result, State
_state, [Msg]
_logs) = State
-> Deriver State Error Val -> (Either Error Val, State, [Msg])
forall st err a. st -> Deriver st err a -> RunResult st err a
Derive.run (State -> State
state_derive State
state) (Deriver State Error Val -> (Either Error Val, State, [Msg]))
-> Deriver State Error Val -> (Either Error Val, State, [Msg])
forall a b. (a -> b) -> a -> b
$ do
        Call Val
call <- case Expr
expr of
            Call Val
call :| [] -> Call Val -> Deriver State Error (Call Val)
forall (m :: * -> *) a. Monad m => a -> m a
return Call Val
call
            Expr
_ -> Key -> Deriver State Error (Call Val)
forall a. HasCallStack => Key -> Deriver a
Derive.throw Key
"expected a val call, but got a full expression"
        Context Tagged -> Term Val -> Deriver State Error Val
forall a.
Taggable a =>
Context a -> Term Val -> Deriver State Error Val
Eval.eval (State -> Context Tagged
state_context State
state) (Call Val -> Term Val
forall val. Call val -> Term val
Expr.ValCall Call Val
call)

lookup_default :: Derive.EnvironDefault -> State -> ArgName -> Maybe DeriveT.Val
lookup_default :: EnvironDefault -> State -> ArgName -> Maybe Val
lookup_default EnvironDefault
env_default State
state ArgName
name =
    [Maybe Val] -> Maybe Val
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe Val] -> Maybe Val) -> [Maybe Val] -> Maybe Val
forall a b. (a -> b) -> a -> b
$ (Key -> Maybe Val) -> [Key] -> [Maybe Val]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Maybe Val
lookup ([Key] -> [Maybe Val]) -> [Key] -> [Maybe Val]
forall a b. (a -> b) -> a -> b
$ CallName -> ArgName -> EnvironDefault -> [Key]
environ_keys (State -> CallName
state_call_name State
state) ArgName
name EnvironDefault
env_default
    where lookup :: Key -> Maybe Val
lookup Key
key = Key -> Environ -> Maybe Val
Env.lookup Key
key (State -> Environ
state_environ State
state)

environ_keys :: CallName -> ArgName -> Derive.EnvironDefault -> [Env.Key]
environ_keys :: CallName -> ArgName -> EnvironDefault -> [Key]
environ_keys CallName
call_name ArgName
arg_name EnvironDefault
env_default = case EnvironDefault
env_default of
    EnvironDefault
Derive.None -> []
    EnvironDefault
Derive.Prefixed -> [Key
prefixed]
    EnvironDefault
Derive.Unprefixed -> [Key
unprefixed]
    EnvironDefault
Derive.Both -> [Key
unprefixed, Key
prefixed]
    where
    prefixed :: Key
prefixed = CallName -> ArgName -> Key
prefixed_environ CallName
call_name ArgName
arg_name
    unprefixed :: Key
unprefixed = (\(Derive.ArgName Key
n) -> Key
n) ArgName
arg_name

prefixed_environ :: CallName -> ArgName -> Env.Key
prefixed_environ :: CallName -> ArgName -> Key
prefixed_environ (Derive.CallName Key
call_name) (Derive.ArgName Key
arg_name) =
    Key
call_name Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"-" Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
arg_name


-- * call

-- | Similar to 'Derive.GeneratorF', but leaves the PassedArgs prev val
-- type free.  This is important for val calls, which use Tagged.
type Generator y d = Derive.PassedArgs y -> Derive.Deriver d
type Transformer y d =
    Derive.PassedArgs y -> Derive.Deriver d -> Derive.Deriver d

call :: Derive.Taggable y => Parser a -> (a -> Generator y d)
    -> Derive.WithArgDoc (Generator y d)
call :: forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
call Parser a
parser a -> Generator y d
f = (Generator y d
go, Parser a -> Docs
forall a. Parser a -> Docs
parser_docs Parser a
parser)
    where
    go :: Generator y d
go PassedArgs y
args = Parser a -> PassedArgs y -> Deriver (Either Error a)
forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse_transformer Parser a
parser PassedArgs y
args Deriver (Either Error a)
-> (Either Error a -> Deriver State Error a)
-> Deriver State Error a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Error a -> Deriver State Error a
forall a. Either Error a -> Deriver a
require_right Deriver State Error a
-> (a -> Deriver State Error d) -> Deriver State Error d
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> a -> Generator y d
f a
a PassedArgs y
args

call_sub :: Derive.Taggable y => Parser a -> (a -> Generator y d)
    -> Derive.WithArgDoc (Generator y d)
call_sub :: forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
call_sub Parser a
parser a -> Generator y d
f = (Generator y d
go, Parser a -> Docs
forall a. Parser a -> Docs
parser_docs Parser a
parser)
    where go :: Generator y d
go PassedArgs y
args = Parser a -> PassedArgs y -> Deriver (Either Error a)
forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse Parser a
parser PassedArgs y
args Deriver (Either Error a)
-> (Either Error a -> Deriver State Error a)
-> Deriver State Error a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Error a -> Deriver State Error a
forall a. Either Error a -> Deriver a
require_right Deriver State Error a
-> (a -> Deriver State Error d) -> Deriver State Error d
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> a -> Generator y d
f a
a PassedArgs y
args

-- | Specialization of 'call' for 0 arguments.
call0 :: Derive.Taggable y => Generator y d -> Derive.WithArgDoc (Generator y d)
call0 :: forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
call0 Generator y d
f = (Generator y d
go, [])
    where
    go :: Generator y d
go PassedArgs y
args = Parser () -> PassedArgs y -> Deriver (Either Error ())
forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse_transformer (() -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) PassedArgs y
args Deriver (Either Error ())
-> (Either Error () -> Deriver State Error ())
-> Deriver State Error ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Error () -> Deriver State Error ()
forall a. Either Error a -> Deriver a
require_right
        Deriver State Error ()
-> (() -> Deriver State Error d) -> Deriver State Error d
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \() -> Generator y d
f PassedArgs y
args

callt :: Derive.Taggable y => Parser a -> (a -> Transformer y d)
    -> Derive.WithArgDoc (Transformer y d)
callt :: forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
callt Parser a
parser a -> Transformer y d
f = (Transformer y d
go, Parser a -> Docs
forall a. Parser a -> Docs
parser_docs Parser a
parser)
    where
    go :: Transformer y d
go PassedArgs y
args Deriver d
deriver = Parser a -> PassedArgs y -> Deriver (Either Error a)
forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse_transformer Parser a
parser PassedArgs y
args Deriver (Either Error a)
-> (Either Error a -> Deriver State Error a)
-> Deriver State Error a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Error a -> Deriver State Error a
forall a. Either Error a -> Deriver a
require_right
        Deriver State Error a -> (a -> Deriver d) -> Deriver d
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> a -> Transformer y d
f a
a PassedArgs y
args Deriver d
deriver

-- | Specialization of 'callt' for 0 arguments.
call0t :: Derive.Taggable y => Transformer y d
    -> Derive.WithArgDoc (Transformer y d)
call0t :: forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
call0t Transformer y d
f = (Transformer y d
go, [])
    where
    go :: Transformer y d
go PassedArgs y
args Deriver d
deriver = Parser () -> PassedArgs y -> Deriver (Either Error ())
forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse_transformer (() -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) PassedArgs y
args Deriver (Either Error ())
-> (Either Error () -> Deriver State Error ())
-> Deriver State Error ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Error () -> Deriver State Error ()
forall a. Either Error a -> Deriver a
require_right
        Deriver State Error () -> (() -> Deriver d) -> Deriver d
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \() -> Transformer y d
f PassedArgs y
args Deriver d
deriver

state_environ :: State -> DeriveT.Environ
state_environ :: State -> Environ
state_environ = Dynamic -> Environ
Derive.state_environ (Dynamic -> Environ) -> (State -> Dynamic) -> State -> Environ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
Derive.state_dynamic (State -> Dynamic) -> (State -> State) -> State -> Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State
state_derive