-- 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.Ref'.  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@.
    TODO: out of date, there is no longer Typecheck ControlRef, they are
    resolved by Typecheck.from_val

    - 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(parser_docs), Generator, Transformer
    , Arg(..)
    , check, parse_or_throw, require_right, parse, parse_vals
    , Dummy
    -- * 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(..)
    , 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.ShowVal as ShowVal
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck
import qualified Derive.ValType as ValType

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 = 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_args :: ![Arg]
    -- | This has to be incremented every time a Val is taken.  Pairing argnums
    -- in state_args 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) = forall a. Pretty a => a -> Doc
Pretty.format Val
val
    format (SubTrack Track
track) = forall a. Pretty a => a -> Doc
Pretty.format Track
track

show_arg :: Arg -> Text
show_arg :: Arg -> Key
show_arg (LiteralArg Val
val) = 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 forall a. Parser a -> State -> Either Error (State, a)
parser_parser Parser a
parser State
state of
    Left Error
err -> forall a b. a -> Either a b
Left Error
err
    Right (State
state, a
a) -> case State -> [Arg]
state_args State
state of
        [] -> forall a b. b -> Either a b
Right a
a
        [Arg]
args -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Key -> Error
Derive.ArgError forall a b. (a -> b) -> a -> b
$ Key
"too many arguments: "
            forall a. Semigroup a => a -> a -> a
<> Key -> [Key] -> Key
Text.intercalate 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Docs -> (State -> Either Error (State, a)) -> Parser a
Parser forall a. Monoid a => a
mempty (\State
state -> 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 =
        forall a. Docs -> (State -> Either Error (State, a)) -> Parser a
Parser (Docs
doc1 forall a. Semigroup a => a -> a -> a
<> Docs
doc2) 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
            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) = forall a. Docs -> (State -> Either Error (State, a)) -> Parser a
Parser Docs
docs forall a b. (a -> b) -> a -> b
$ \State
state -> case State -> Either Error (State, a)
parse State
state of
    Left Error
err -> 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 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Key -> Error
Derive.ArgError Key
err
        Maybe Key
Nothing -> 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 = forall a. Either Error a -> Deriver a
require_right forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => ErrorVal -> Deriver a
Derive.throw_error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> ErrorVal
Derive.CallError) 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 <- forall d. PassedArgs d -> Deriver [Track]
Sub.sub_tracks PassedArgs d
args
    forall a. Parser a -> State -> Either Error a
run_parser Parser a
parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Track] -> State -> State
make_state [Track]
sub_tracks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall st err. Deriver st err st
Derive.get
    where
    make_state :: [Track] -> State -> State
make_state [Track]
sub_tracks State
state = State
        { state_args :: [Arg]
state_args = forall a b. (a -> b) -> [a] -> [b]
map Val -> Arg
LiteralArg (forall val. PassedArgs val -> [Val]
Derive.passed_vals PassedArgs d
args)
            forall a. [a] -> [a] -> [a]
++ 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 = 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 = forall a. Taggable a => Context a -> Context Tagged
Derive.tag_context (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 =
    forall a.
Parser a
-> Context Tagged -> CallName -> [Val] -> Deriver (Either Error a)
parse_vals Parser a
parser (forall a. Taggable a => Context a -> Context Tagged
Derive.tag_context (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args))
        (forall val. PassedArgs val -> CallName
Derive.passed_call_name PassedArgs d
args) (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 = forall a. Parser a -> State -> Either Error a
run_parser Parser a
parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State
make_state forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall st err. Deriver st err st
Derive.get
    where
    make_state :: State -> State
make_state State
state = State
        { state_args :: [Arg]
state_args = 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
        }

-- | Now that the default can be any ToVal and may be a different type than the
-- parser, it can get ambiguous, especially if it's a Nothing or [].  Since all
-- that matters is (show_val . to_val), and show_val of Nothing or [] is always
-- _ or (list), the type doesn't matter.  I could use Int, but I'll use this to
-- explicitly mark that it doesn't matter.
data Dummy
instance Typecheck.ToVal Dummy where
    to_val :: Dummy -> Val
to_val Dummy
_ = Val
DeriveT.VNotGiven

-- * 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 = 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 = 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 = forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc forall a b. (a -> b) -> a -> b
$ \State
state1 ->
    case EnvironDefault -> State -> ArgName -> Maybe (State, Arg)
take_arg EnvironDefault
env_default State
state1 ArgName
name of
        Maybe (State, Arg)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Key -> Error
Derive.ArgError forall a b. (a -> b) -> a -> b
$
            Key
"expected an argument at " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty ArgName
name
        Just (State
state, Arg
arg) -> (State
state,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            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 = forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (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 deflt.  (Typecheck.Typecheck a, Typecheck.ToVal deflt)
    => ArgName -> deflt -> Doc.Doc -> Parser a
defaulted :: forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
name = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
defaulted_env ArgName
name EnvironDefault
Derive.Prefixed

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

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

defaulted_env_ :: forall a. Typecheck.Typecheck a
    => ArgName -> Derive.EnvironDefault -> Either DeriveT.Val DeriveT.Quoted
    -> Doc.Doc -> Parser a
defaulted_env_ :: forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Either Val Quoted -> Doc -> Parser a
defaulted_env_ ArgName
name EnvironDefault
env_default Either Val Quoted
deflt_quoted Doc
doc = forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc forall a b. (a -> b) -> a -> b
$ \State
state1 ->
    case EnvironDefault -> State -> ArgName -> Maybe (State, Arg)
take_arg EnvironDefault
env_default State
state1 ArgName
name of
        Maybe (State, Arg)
Nothing -> forall {a}. Typecheck a => State -> Either Error (State, a)
deflt State
state1
        Just (State
state, LiteralArg Val
DeriveT.VNotGiven) -> forall {a}. Typecheck a => State -> Either Error (State, a)
deflt State
state
        Just (State
state, Arg
arg) -> (State
state,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            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
    deflt :: State -> Either Error (State, a)
deflt State
state =
        forall a.
Typecheck a =>
ArgDoc
-> ErrorPlace
-> ArgName
-> State
-> Either Val Quoted
-> Either Error (State, a)
eval_default ArgDoc
arg_doc (State -> ErrorPlace
argnum_error State
state) ArgName
name State
state Either Val Quoted
deflt_quoted
    expected :: Type
expected = forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (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 forall a b. (a -> b) -> a -> b
$ forall a. ShowVal a => a -> Key
ShowVal.show_val forall a b. (a -> b) -> a -> b
$
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. ToVal a => a -> Val
Typecheck.to_val Either Val 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, Typecheck.ToVal deflt) =>
    ArgName -> Maybe deflt -> Doc.Doc -> Parser a
maybe_defaulted :: forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> Maybe deflt -> Doc -> Parser a
maybe_defaulted ArgName
name Maybe deflt
Nothing Doc
doc = forall a. Typecheck a => ArgName -> Doc -> Parser a
required ArgName
name Doc
doc
maybe_defaulted ArgName
name (Just deflt
deflt) Doc
doc = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
name deflt
deflt Doc
doc

-- | Eval a Quoted default value.
eval_default :: forall a. Typecheck.Typecheck a => Derive.ArgDoc
    -> Derive.ErrorPlace -> ArgName -> State
    -> Either DeriveT.Val DeriveT.Quoted -> Either Error (State, a)
eval_default :: forall a.
Typecheck a =>
ArgDoc
-> ErrorPlace
-> ArgName
-> State
-> Either Val Quoted
-> Either Error (State, a)
eval_default ArgDoc
arg_doc ErrorPlace
place ArgName
name State
state = \case
    Left Val
val -> (State
state,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        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)
    Right Quoted
quoted -> case State -> Quoted -> Either Error Val
eval_quoted State
state Quoted
quoted of
        Right Val
val -> (State
state,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            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)
        Left Error
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TypeErrorT -> Error
Derive.TypeError 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 = forall a. Maybe a
Nothing
            , error_derive :: Maybe Error
error_derive = forall a. a -> Maybe a
Just Error
err
            }
    where
    expected_type :: Type
expected_type = forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (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.  So it's like 'defaulted' except there is no positional argument.
--
-- Of course, the call could just look in the environ itself, but this way it's
-- uniform and automatically documented.
environ :: forall a deflt. (Typecheck.Typecheck a, Typecheck.ToVal deflt) =>
    ArgName -> Derive.EnvironDefault
    -- ^ None doesn't make any sense, but, well, don't pass that then.
    -> deflt -> Doc.Doc -> Parser a
environ :: forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
environ ArgName
name EnvironDefault
env_default = forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Either Val Quoted -> Doc -> Parser a
environ_ ArgName
name EnvironDefault
env_default forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToVal a => a -> Val
Typecheck.to_val

-- | A shortcut for an unprefixed environ key.
environ_key :: (Typecheck.Typecheck a, Typecheck.ToVal deflt) =>
    Env.Key -> deflt -> Doc.Doc -> Parser a
environ_key :: forall a deflt.
(Typecheck a, ToVal deflt) =>
Key -> deflt -> Doc -> Parser a
environ_key Key
key = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> 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 =>
    ArgName -> Derive.EnvironDefault -> DeriveT.Quoted -> Doc.Doc -> Parser a
environ_quoted :: forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Quoted -> Doc -> Parser a
environ_quoted ArgName
name EnvironDefault
env_default = forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Either Val Quoted -> Doc -> Parser a
environ_ ArgName
name EnvironDefault
env_default forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right

-- Internal function that handles both quoted and unquoted default.
environ_ :: forall a. Typecheck.Typecheck a => ArgName -> Derive.EnvironDefault
    -- ^ None doesn't make any sense, but, well, don't pass that then.
    -> Either DeriveT.Val DeriveT.Quoted -> Doc.Doc -> Parser a
environ_ :: forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Either Val Quoted -> Doc -> Parser a
environ_ ArgName
name EnvironDefault
env_default Either Val Quoted
quoted Doc
doc = forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc 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 -> forall {a}. Typecheck a => State -> Either Error (State, a)
deflt State
state
        Just Val
val -> (State
state,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            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 = forall a.
Typecheck a =>
ArgDoc
-> ErrorPlace
-> ArgName
-> State
-> Either Val Quoted
-> Either Error (State, a)
eval_default ArgDoc
arg_doc (State -> ErrorPlace
argnum_error State
state) ArgName
name State
state Either Val Quoted
quoted
    expected :: Type
expected = forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (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 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. ShowVal a => a -> Key
ShowVal.show_val forall a. ShowVal a => a -> Key
ShowVal.show_val Either Val 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 = forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc 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 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TypeErrorT -> Error
Derive.TypeError 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 = forall a. Maybe a
Nothing
            , error_derive :: Maybe Error
error_derive = forall a. Maybe a
Nothing
            }
        Just Val
val -> (State
state,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            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 = forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (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 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 = 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 = 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 = forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc forall a b. (a -> b) -> a -> b
$ \State
state1 ->
    case EnvironDefault -> State -> ArgName -> Maybe (State, Arg)
take_arg EnvironDefault
env_default State
state1 ArgName
name of
        Maybe (State, Arg)
Nothing -> forall a b. b -> Either a b
Right (State
state1, a
deflt)
        Just (State
state, LiteralArg Val
DeriveT.VNotGiven) -> forall a b. b -> Either a b
Right (State
state, a
deflt)
        Just (State
state, Arg
arg) ->
            case 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 -> 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 -> forall a b. b -> Either a b
Right (State
replaced, a
deflt)
                        Just Val
val -> (State
replaced,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
replaced ArgDoc
arg_doc (State -> ErrorPlace
argnum_error State
state1)
                                ArgName
name (Val -> Arg
LiteralArg Val
val)
                Left Error
err -> forall a b. a -> Either a b
Left Error
err
            where replaced :: State
replaced = State
state { state_args :: [Arg]
state_args = Arg
arg forall a. a -> [a] -> [a]
: State -> [Arg]
state_args State
state }
    where
    expected :: Type
expected = forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (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 (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 = forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser ArgDoc
arg_doc forall a b. (a -> b) -> a -> b
$ \State
state -> do
    [a]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a}. Typecheck a => State -> (Int, Arg) -> Either Error a
typecheck State
state)
        (forall a b. [a] -> [b] -> [(a, b)]
zip [State -> Int
state_argnum State
state ..] (State -> [Arg]
state_args State
state))
    let state2 :: State
state2 = Int -> State -> State
increment_argnum (forall (t :: * -> *) a. Foldable t => t a -> Int
length (State -> [Arg]
state_args State
state)) forall a b. (a -> b) -> a -> b
$
            State
state { state_args :: [Arg]
state_args = []}
    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) =
        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 = forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (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 = 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 = forall a. ArgName -> Parser [a] -> Parser (NonEmpty a)
non_empty ArgName
name forall a b. (a -> b) -> a -> b
$ 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 = forall a. ArgDoc -> (State -> Either Error (State, a)) -> Parser a
parser (Type -> ArgDoc
arg_doc Type
expected) forall a b. (a -> b) -> a -> b
$ \State
state -> do
    let args :: [Arg]
args = State -> [Arg]
state_args State
state
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Integral a => a -> Bool
odd (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg]
args)) forall a b. (a -> b) -> a -> b
$
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Key -> Error
Derive.ArgError forall a b. (a -> b) -> a -> b
$ Key
"many_pairs requires an even argument length: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Key
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg]
args)
    [(a, b)]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a} {a}.
(Typecheck a, Typecheck a) =>
State -> (Int, (Arg, Arg)) -> Either Error (a, a)
typecheck State
state) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [State -> Int
state_argnum State
state ..] (forall {b}. [b] -> [(b, b)]
pairs [Arg]
args)
    let state2 :: State
state2 = Int -> State -> State
increment_argnum (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, b)]
vals) forall a b. (a -> b) -> a -> b
$ State
state { state_args :: [Arg]
state_args = [] }
    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
arg1, Arg
arg2)) = (,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state (Type -> ArgDoc
arg_doc (forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)))
            (Int -> ErrorPlace
Derive.TypeErrorArg (Int
argnum forall a. Num a => a -> a -> a
* Int
2)) ArgName
name Arg
arg1
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
Typecheck a =>
State -> ArgDoc -> ErrorPlace -> ArgName -> Arg -> Either Error a
check_arg State
state (Type -> ArgDoc
arg_doc (forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (forall {k} (t :: k). Proxy t
Proxy :: Proxy b)))
            (Int -> ErrorPlace
Derive.TypeErrorArg (Int
argnum forall a. Num a => a -> a -> a
* Int
2 forall a. Num a => a -> a -> a
+ Int
1)) ArgName
name Arg
arg2
    expected :: Type
expected = Type -> Type -> Type
ValType.TPair (forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))
        (forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (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) 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 = forall a. ArgName -> Parser [a] -> Parser (NonEmpty a)
non_empty ArgName
name forall a b. (a -> b) -> 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) =
    forall a. Docs -> (State -> Either Error (State, a)) -> Parser a
Parser (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 -> forall a b. a -> Either a b
Left Error
err
        Right (State
_, []) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Key -> Error
Derive.ArgError forall a b. (a -> b) -> a -> b
$
            Key
"arg requires at least one value: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty ArgName
name
        Right (State
state, a
x : [a]
xs) -> forall a b. b -> Either a b
Right (State
state, a
x 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 = forall a. Docs -> (State -> Either Error (State, a)) -> Parser a
Parser Docs
docs 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 = forall a b. b -> Either a b
Right (State
state2, [Arg]
vals)
        where
        ([Arg]
vals, [Arg]
rest) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length Docs
docs) (State -> [Arg]
state_args State
state)
        state2 :: State
state2 = Int -> State -> State
increment_argnum (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg]
vals) forall a b. (a -> b) -> a -> b
$ State
state { state_args :: [Arg]
state_args = [Arg]
rest}

argnum_error :: State -> Derive.ErrorPlace
argnum_error :: State -> ErrorPlace
argnum_error = Int -> ErrorPlace
Derive.TypeErrorArg 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 forall a. Num a => a -> a -> a
+ State -> Int
state_argnum State
state }

-- ** util

take_arg :: Derive.EnvironDefault -> State -> ArgName -> Maybe (State, Arg)
take_arg :: EnvironDefault -> State -> ArgName -> Maybe (State, Arg)
take_arg EnvironDefault
env_default State
state ArgName
name = case State -> [Arg]
state_args State
state of
    Arg
v : [Arg]
vs -> forall a. a -> Maybe a
Just
        ( State
next { state_args :: [Arg]
state_args = [Arg]
vs }
        , case Arg
v of
            LiteralArg Val
DeriveT.VNotGiven ->
                Val -> Arg
LiteralArg forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Val
DeriveT.VNotGiven 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,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Arg
LiteralArg 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 = \case
    LiteralArg Val
val -> case forall a. Typecheck a => State -> Val -> Either Error (Maybe a)
from_val State
state Val
val of
        Left Error
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ EvalSource -> Maybe Val -> Maybe Error -> Error
type_error EvalSource
Derive.Literal (forall a. a -> Maybe a
Just Val
val) (forall a. a -> Maybe a
Just Error
err)
        Right (Just a
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 <- forall {p :: * -> * -> *} {c}.
Bifunctor p =>
EvalSource -> Val -> p Error c -> p Error c
promote_error EvalSource
source Val
val forall a b. (a -> b) -> a -> b
$ State -> Quoted -> Either Error Val
eval_quoted State
state Quoted
quoted
                Maybe a
maybe_a <- forall {p :: * -> * -> *} {c}.
Bifunctor p =>
EvalSource -> Val -> p Error c -> p Error c
promote_error EvalSource
source Val
qval forall a b. (a -> b) -> a -> b
$ 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 -> forall a b. b -> Either a b
Right a
a
                    Maybe a
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ EvalSource -> Maybe Val -> Maybe Error -> Error
type_error EvalSource
source (forall a. a -> Maybe a
Just Val
qval) forall a. Maybe a
Nothing
            Val
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ EvalSource -> Maybe Val -> Maybe Error -> Error
type_error EvalSource
Derive.Literal (forall a. a -> Maybe a
Just Val
val) forall a. Maybe a
Nothing
    SubTrack Track
track -> case forall a. Typecheck a => Track -> Maybe a
Typecheck.from_subtrack Track
track of
        Just a
a -> forall a b. b -> Either a b
Right a
a
        Maybe a
Nothing -> forall a b. a -> Either a b
Left 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)) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    where
    promote_error :: EvalSource -> Val -> p Error c -> p Error c
promote_error EvalSource
source Val
val = 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 (forall a. a -> Maybe a
Just Val
val) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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
        }

-- | 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 = forall a. State -> Deriver a -> Either Error a
run State
state forall a b. (a -> b) -> a -> b
$ case forall a. Typecheck a => Val -> Checked a
Typecheck.from_val Val
val of
    Typecheck.Val Result a
result -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Result a
result of
        Result a
Typecheck.Failure -> forall a. Maybe a
Nothing
        Typecheck.Success a
a -> forall a. a -> Maybe a
Just a
a
        Typecheck.Derive Context Tagged -> a
deriver -> forall a. a -> Maybe a
Just 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScoreTime -> Deriver RealTime
Derive.score_to_real ScoreTime
start
    where start :: ScoreTime
start = Event -> ScoreTime
Event.start forall a b. (a -> b) -> a -> b
$ forall val. Context val -> Event
Derive.ctx_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 = 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 = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> NoteDeriver
Sub.derive 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 = 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 = 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 -> forall a. Result a -> Checked a
Typecheck.Val forall a b. (a -> b) -> a -> b
$ forall a. (Context Tagged -> a) -> Result a
Typecheck.Derive forall a b. (a -> b) -> a -> b
$
        \Context Tagged
ctx -> forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (forall a. Taggable a => Context Tagged -> Context a
Derive.untag_context Context Tagged
ctx) Quoted
quoted
    Maybe Quoted
Nothing -> 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 -> forall a. a -> Maybe a
Just Quoted
a
    DeriveT.VStr (Expr.Str Key
sym) ->
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Expr -> Quoted
DeriveT.Quoted forall a b. (a -> b) -> a -> b
$ forall val. Symbol -> [Term val] -> Call val
Expr.Call (Key -> Symbol
Expr.Symbol Key
sym) [] forall a. a -> [a] -> NonEmpty a
:| []
    Val
_ -> 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) = 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) = forall st err a. st -> Deriver st err a -> RunResult st err a
Derive.run (State -> State
state_derive State
state) forall a b. (a -> b) -> a -> b
$ do
        Call Val
call <- case Expr
expr of
            Call Val
call :| [] -> forall (m :: * -> *) a. Monad m => a -> m a
return Call Val
call
            Expr
_ -> forall a. HasCallStack => Key -> Deriver a
Derive.throw Key
"expected a val call, but got a full expression"
        forall a.
Taggable a =>
Context a -> Term -> Deriver State Error Val
Eval.eval (State -> Context Tagged
state_context State
state) (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 =
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Key -> Maybe Val
lookup 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 = \case
    EnvironDefault
None -> []
    EnvironDefault
Prefixed
        | CallName
call_name forall a. Eq a => a -> a -> Bool
== CallName
"" -> [Key
unprefixed]
        | Bool
otherwise -> [Key
prefixed]
    EnvironDefault
Unprefixed -> [Key
unprefixed]
    EnvironDefault
Both
        | CallName
call_name forall a. Eq a => a -> a -> Bool
== CallName
"" -> [Key
unprefixed]
        | Bool
otherwise -> [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 forall a. Semigroup a => a -> a -> a
<> 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, forall a. Parser a -> Docs
parser_docs Parser a
parser)
    where
    go :: Generator y d
go PassedArgs y
args = forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse_transformer Parser a
parser PassedArgs y
args forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Either Error a -> Deriver a
require_right 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, forall a. Parser a -> Docs
parser_docs Parser a
parser)
    where go :: Generator y d
go PassedArgs y
args = forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse Parser a
parser PassedArgs y
args forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Either Error a -> Deriver a
require_right 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 = forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse_transformer (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) PassedArgs y
args forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Either Error a -> Deriver a
require_right
        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, forall a. Parser a -> Docs
parser_docs Parser a
parser)
    where
    go :: Transformer y d
go PassedArgs y
args Deriver d
deriver = forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse_transformer Parser a
parser PassedArgs y
args forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Either Error a -> Deriver a
require_right
        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 = forall d a.
Taggable d =>
Parser a -> PassedArgs d -> Deriver (Either Error a)
parse_transformer (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) PassedArgs y
args forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Either Error a -> Deriver a
require_right
        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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Dynamic
Derive.state_dynamic forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State
state_derive