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

-- | Ad-hoc parsing for note tracks.  This is a bit hacky because it's trying
-- to guess syntactically how an expression will be evaluated, but it's
-- convenient to do it this way, because otherwise I need to either have a
-- special kind of evaluation, or I need to have evaluate emit metadata, and
-- then wait for a full derive to complete.  In addition, expressions that are
-- being edited might not parse, or their caller might fail, or something.
module Cmd.NoteTrackParse where
import qualified Data.Map as Map

import qualified Util.Lists as Lists
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Parse as Parse

import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Id as Id
import qualified Ui.Ui as Ui

import           Global
import           Types


track_block_calls :: Ui.M m => Bool -> BlockId -> TrackId
    -> m [(Event.Event, NonEmpty BlockId)]
track_block_calls :: forall (m :: * -> *).
M m =>
Bool -> BlockId -> TrackId -> m [(Event, NonEmpty BlockId)]
track_block_calls Bool
look_in_args BlockId
block_id TrackId
track_id = do
    [Event]
events <- Events -> [Event]
Events.ascending forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => TrackId -> m Events
Ui.get_events TrackId
track_id
    Text -> Maybe BlockId
to_bid <- forall (m :: * -> *).
M m =>
Maybe BlockId -> m (Text -> Maybe BlockId)
get_to_block_id (forall a. a -> Maybe a
Just BlockId
block_id)
    let bids :: [[BlockId]]
bids = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Bool -> (Text -> Maybe a) -> Text -> [a]
block_calls_of Bool
look_in_args Text -> Maybe BlockId
to_bid forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Text
Event.text) [Event]
events
    forall (m :: * -> *) a. Monad m => a -> m a
return [(Event
event, BlockId
b forall a. a -> [a] -> NonEmpty a
:| [BlockId]
bs) | (Event
event, BlockId
b:[BlockId]
bs) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Event]
events [[BlockId]]
bids]

expr_block_calls :: Ui.M m => Bool -> BlockId -> Text -> m [BlockId]
expr_block_calls :: forall (m :: * -> *). M m => Bool -> BlockId -> Text -> m [BlockId]
expr_block_calls Bool
look_in_args BlockId
caller Text
expr = do
    Text -> Maybe BlockId
to_bid <- forall (m :: * -> *).
M m =>
Maybe BlockId -> m (Text -> Maybe BlockId)
get_to_block_id (forall a. a -> Maybe a
Just BlockId
caller)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Bool -> (Text -> Maybe a) -> Text -> [a]
block_calls_of Bool
look_in_args Text -> Maybe BlockId
to_bid Text
expr

-- | Try to to figure out any blocks that are referenced in the expression.
--
-- This doesn't use the full Derive.Parse machinery, but is simple and doesn't
-- require the text to be fully parseable.
block_calls_of :: Bool -- ^ If True, and the call wasn't a block, see if any
    -- of the arguments name blocks.  This is for calls like @alt@, which take
    -- blocks as arguments.
    -> (Text -> Maybe a) -> Text -> [a]
block_calls_of :: forall a. Bool -> (Text -> Maybe a) -> Text -> [a]
block_calls_of Bool
look_in_args Text -> Maybe a
to_bid Text
expr = case [Text]
syms of
    [] -> []
    Text
b : [Text]
bs -> case Text -> Maybe a
to_bid Text
b of
        Maybe a
Nothing -> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe a
to_bid [Text]
bs
        Just a
block_id -> [a
block_id]
    where
    syms :: [Text]
syms = (if Bool
look_in_args then forall a. a -> a
id else forall a. Int -> [a] -> [a]
take Int
1) forall a b. (a -> b) -> a -> b
$ Text -> [Text]
possible_block_calls Text
expr

get_to_block_id :: Ui.M m => Maybe BlockId -> m (Text -> Maybe BlockId)
get_to_block_id :: forall (m :: * -> *).
M m =>
Maybe BlockId -> m (Text -> Maybe BlockId)
get_to_block_id Maybe BlockId
caller = do
    Map BlockId Block
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks
    Namespace
ns <- forall (m :: * -> *). M m => m Namespace
Ui.get_namespace
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Map BlockId a
-> Namespace -> Maybe BlockId -> Text -> Maybe BlockId
to_block_id Map BlockId Block
blocks Namespace
ns Maybe BlockId
caller

-- | If the first word names a block, then it's probably a block call with
-- args, so return just that.  Otherwise, return any argument that names
-- a block.
to_block_id :: Map BlockId a -> Id.Namespace -> Maybe BlockId -> Text
    -> (Maybe BlockId)
to_block_id :: forall a.
Map BlockId a
-> Namespace -> Maybe BlockId -> Text -> Maybe BlockId
to_block_id Map BlockId a
blocks Namespace
ns Maybe BlockId
caller =
    BlockId -> Maybe BlockId
valid forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Namespace -> Maybe BlockId -> Symbol -> Maybe BlockId
Eval.call_to_block_id Namespace
ns Maybe BlockId
caller forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Symbol
Expr.Symbol
    where
    valid :: BlockId -> Maybe BlockId
valid BlockId
block_id
        | Just a
_ <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id Map BlockId a
blocks = forall a. a -> Maybe a
Just BlockId
block_id
        | Bool
otherwise = forall a. Maybe a
Nothing

possible_block_calls :: Text -> [Text]
possible_block_calls :: Text -> [Text]
possible_block_calls = forall a. a -> Maybe a -> a
fromMaybe [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.last forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [[Text]]
Parse.split_pipeline