-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
module Derive.Stack (
    Stack, empty, length, from_outermost, from_innermost
    , block, call, add, member, outermost, innermost
    , block_of, track_of, region_of, call_of
    , block_track_of, block_tracks_of, block_track_region_of
    , track_ids_of
    , match
    , Frame(..), Serial
    , format_ui, pretty_ui, pretty_ui_, pretty_ui_inner
    , log_ui_frame

    -- * more specialized utils
    , track_regions

    -- * ui
    , UiFrame, to_ui, to_ui_innermost
    , unparse_ui_frame, unparse_ui_frame_, parse_ui_frame
) where
import qualified Prelude
import           Prelude hiding (length)
import qualified Control.DeepSeq as DeepSeq
import qualified Data.Aeson as Aeson
import qualified Data.Attoparsec.Text as A
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified Text.Read as Read

import qualified Util.Lists as Lists
import qualified Util.Num as Num
import qualified Util.ParseText as ParseText
import qualified Util.Pretty as Pretty
import qualified Util.Ranges as Ranges
import qualified Util.Seed as Seed
import qualified Util.Serialize as Serialize

import qualified Ui.Id as Id
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


-- | The Stack is read in both inner -> outer and outer -> inner order.  Since
-- it's always modified at the innermost end, I keep it in inner -> outer
-- order.
--
-- I originally used "Data.Sequence" but it generates more garbage and
-- I couldn't figure out how to stop that from happening.
newtype Stack = Stack [Frame]
    deriving stock (Stack -> Stack -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stack -> Stack -> Bool
$c/= :: Stack -> Stack -> Bool
== :: Stack -> Stack -> Bool
$c== :: Stack -> Stack -> Bool
Eq, Eq Stack
Stack -> Stack -> Bool
Stack -> Stack -> Ordering
Stack -> Stack -> Stack
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Stack -> Stack -> Stack
$cmin :: Stack -> Stack -> Stack
max :: Stack -> Stack -> Stack
$cmax :: Stack -> Stack -> Stack
>= :: Stack -> Stack -> Bool
$c>= :: Stack -> Stack -> Bool
> :: Stack -> Stack -> Bool
$c> :: Stack -> Stack -> Bool
<= :: Stack -> Stack -> Bool
$c<= :: Stack -> Stack -> Bool
< :: Stack -> Stack -> Bool
$c< :: Stack -> Stack -> Bool
compare :: Stack -> Stack -> Ordering
$ccompare :: Stack -> Stack -> Ordering
Ord)
    deriving newtype (Stack -> ()
forall a. (a -> ()) -> NFData a
rnf :: Stack -> ()
$crnf :: Stack -> ()
DeepSeq.NFData, Get Stack
Putter Stack
forall a. Putter a -> Get a -> Serialize a
get :: Get Stack
$cget :: Get Stack
put :: Putter Stack
$cput :: Putter Stack
Serialize.Serialize, [Stack] -> Encoding
[Stack] -> Value
Stack -> Encoding
Stack -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Stack] -> Encoding
$ctoEncodingList :: [Stack] -> Encoding
toJSONList :: [Stack] -> Value
$ctoJSONList :: [Stack] -> Value
toEncoding :: Stack -> Encoding
$ctoEncoding :: Stack -> Encoding
toJSON :: Stack -> Value
$ctoJSON :: Stack -> Value
Aeson.ToJSON,
        Value -> Parser [Stack]
Value -> Parser Stack
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Stack]
$cparseJSONList :: Value -> Parser [Stack]
parseJSON :: Value -> Parser Stack
$cparseJSON :: Value -> Parser Stack
Aeson.FromJSON)

instance Show Stack where
    show :: Stack -> String
show Stack
stack = String
"Stack.from_outermost " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Stack -> [Frame]
outermost Stack
stack)
instance Read.Read Stack where
    readPrec :: ReadPrec Stack
readPrec = do
        ReadPrec String
Pretty.readWord
        [Frame]
frames <- forall a. Read a => ReadPrec a
Read.readPrec
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Frame] -> Stack
from_outermost [Frame]
frames)

empty :: Stack
empty :: Stack
empty = [Frame] -> Stack
Stack []

length :: Stack -> Int
length :: Stack -> Int
length (Stack [Frame]
f) = forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Frame]
f

-- | Construct a Stack from frames starting with the outermost and ending with
-- the innermost.
from_outermost :: [Frame] -> Stack
from_outermost :: [Frame] -> Stack
from_outermost = [Frame] -> Stack
Stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

-- | Construct a Stack from frames starting with the innermost and ending with
-- the outermost.
from_innermost :: [Frame] -> Stack
from_innermost :: [Frame] -> Stack
from_innermost = [Frame] -> Stack
Stack

-- | Make a Stack with a single block.
block :: BlockId -> Stack
block :: BlockId -> Stack
block = [Frame] -> Stack
from_innermost forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> Frame
Block

-- | Make a Stack with a single call.
call :: Text -> Stack
call :: Text -> Stack
call = [Frame] -> Stack
from_innermost forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Frame
Call

-- | Add the frame to the innermost end of the stack.
add :: Frame -> Stack -> Stack
add :: Frame -> Stack -> Stack
add Frame
frame (Stack [Frame]
stack) = [Frame] -> Stack
Stack (Frame
frameforall a. a -> [a] -> [a]
:[Frame]
stack)

member :: Frame -> Stack -> Bool
member :: Frame -> Stack -> Bool
member Frame
frame (Stack [Frame]
s) = Frame
frame forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Frame]
s

-- | The stack, starting with the outermost call and ending with the innermost.
-- All display should use this order.
outermost :: Stack -> [Frame]
outermost :: Stack -> [Frame]
outermost (Stack [Frame]
s) = forall a. [a] -> [a]
reverse [Frame]
s

-- | The stack, starting with the innermost call and ending with the outermost.
innermost :: Stack -> [Frame]
innermost :: Stack -> [Frame]
innermost (Stack [Frame]
s) = [Frame]
s

block_of :: Frame -> Maybe BlockId
block_of :: Frame -> Maybe BlockId
block_of (Block BlockId
b) = forall a. a -> Maybe a
Just BlockId
b
block_of Frame
_ = forall a. Maybe a
Nothing

track_of :: Frame -> Maybe TrackId
track_of :: Frame -> Maybe TrackId
track_of (Track TrackId
t) = forall a. a -> Maybe a
Just TrackId
t
track_of Frame
_ = forall a. Maybe a
Nothing

region_of :: Frame -> Maybe (TrackTime, TrackTime)
region_of :: Frame -> Maybe (TrackTime, TrackTime)
region_of (Region TrackTime
s TrackTime
e) = forall a. a -> Maybe a
Just (TrackTime
s, TrackTime
e)
region_of Frame
_ = forall a. Maybe a
Nothing

call_of :: Frame -> Maybe Text
call_of :: Frame -> Maybe Text
call_of (Call Text
s) = forall a. a -> Maybe a
Just Text
s
call_of Frame
_ = forall a. Maybe a
Nothing

-- | Walk up the stack to discover the innermost TrackId, then BlockId.
block_track_of :: Stack -> Maybe (BlockId, TrackId)
block_track_of :: Stack -> Maybe (BlockId, TrackId)
block_track_of = [Frame] -> Maybe (BlockId, TrackId)
find forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
innermost
    where
    find :: [Frame] -> Maybe (BlockId, TrackId)
find [Frame]
frames = do
        (TrackId
track_id, [Frame]
frames) <- forall a b. (a -> Maybe b) -> [a] -> Maybe (b, [a])
find_rest Frame -> Maybe TrackId
track_of [Frame]
frames
        (BlockId
block_id, [Frame]
_) <- forall a b. (a -> Maybe b) -> [a] -> Maybe (b, [a])
find_rest Frame -> Maybe BlockId
block_of [Frame]
frames
        forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
block_id, TrackId
track_id)

-- | Get each block and the tracks under it, starting from the innermost.
block_tracks_of :: Stack -> [(BlockId, [TrackId])]
block_tracks_of :: Stack -> [(BlockId, [TrackId])]
block_tracks_of = [TrackId] -> [Frame] -> [(BlockId, [TrackId])]
go [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
innermost
    where
    go :: [TrackId] -> [Frame] -> [(BlockId, [TrackId])]
go [TrackId]
track_ids (Frame
frame : [Frame]
frames) = case Frame
frame of
        Track TrackId
track_id -> [TrackId] -> [Frame] -> [(BlockId, [TrackId])]
go (TrackId
track_id forall a. a -> [a] -> [a]
: [TrackId]
track_ids) [Frame]
frames
        Block BlockId
block_id -> (BlockId
block_id, [TrackId]
track_ids) forall a. a -> [a] -> [a]
: [TrackId] -> [Frame] -> [(BlockId, [TrackId])]
go [] [Frame]
frames
        Frame
_ -> [TrackId] -> [Frame] -> [(BlockId, [TrackId])]
go [TrackId]
track_ids [Frame]
frames
    go [TrackId]
_ [] = []

-- | Walk up the stack to discover the innermost Region, TrackId, then BlockId.
block_track_region_of :: Stack
    -> Maybe (BlockId, TrackId, (TrackTime, TrackTime))
block_track_region_of :: Stack -> Maybe (BlockId, TrackId, (TrackTime, TrackTime))
block_track_region_of = [Frame] -> Maybe (BlockId, TrackId, (TrackTime, TrackTime))
find forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
innermost
    where
    find :: [Frame] -> Maybe (BlockId, TrackId, (TrackTime, TrackTime))
find [Frame]
frames = do
        ((TrackTime, TrackTime)
region, [Frame]
frames) <- forall a b. (a -> Maybe b) -> [a] -> Maybe (b, [a])
find_rest Frame -> Maybe (TrackTime, TrackTime)
region_of [Frame]
frames
        (TrackId
track_id, [Frame]
frames) <- forall a b. (a -> Maybe b) -> [a] -> Maybe (b, [a])
find_rest Frame -> Maybe TrackId
track_of [Frame]
frames
        (BlockId
block_id, [Frame]
_) <- forall a b. (a -> Maybe b) -> [a] -> Maybe (b, [a])
find_rest Frame -> Maybe BlockId
block_of [Frame]
frames
        forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
block_id, TrackId
track_id, (TrackTime, TrackTime)
region)

track_ids_of :: Stack -> [TrackId]
track_ids_of :: Stack -> [TrackId]
track_ids_of = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Frame -> Maybe TrackId
track_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
innermost

-- | Find a value, and return the rest of the list.
find_rest :: (a -> Maybe b) -> [a] -> Maybe (b, [a])
find_rest :: forall a b. (a -> Maybe b) -> [a] -> Maybe (b, [a])
find_rest a -> Maybe b
f = [a] -> Maybe (b, [a])
go
    where
    go :: [a] -> Maybe (b, [a])
go (a
x:[a]
xs) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([a] -> Maybe (b, [a])
go [a]
xs) (\b
y -> forall a. a -> Maybe a
Just (b
y, [a]
xs)) (a -> Maybe b
f a
x)
    go [] = forall a. Maybe a
Nothing

-- | Nothing is a wildcard, and matches anything, but if a field is set then it
-- only matches frames where the corresponding field is set, and is equal (or
-- overlaps in the case of range).
type Pattern =
    (Maybe BlockId, Maybe (Set TrackId), Maybe (TrackTime, TrackTime))

match :: Pattern -> Stack -> Bool
match :: Pattern -> Stack -> Bool
match Pattern
pattern = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Pattern -> UiFrame -> Bool
ui_match Pattern
pattern) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [UiFrame]
to_ui

-- ** frames

data Frame =
    Block !BlockId
    | Track !TrackId
    | Region !TrackTime !TrackTime
    | Call !Text
    | Serial !Serial
    deriving stock (Frame -> Frame -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Frame -> Frame -> Bool
$c/= :: Frame -> Frame -> Bool
== :: Frame -> Frame -> Bool
$c== :: Frame -> Frame -> Bool
Eq, Eq Frame
Frame -> Frame -> Bool
Frame -> Frame -> Ordering
Frame -> Frame -> Frame
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Frame -> Frame -> Frame
$cmin :: Frame -> Frame -> Frame
max :: Frame -> Frame -> Frame
$cmax :: Frame -> Frame -> Frame
>= :: Frame -> Frame -> Bool
$c>= :: Frame -> Frame -> Bool
> :: Frame -> Frame -> Bool
$c> :: Frame -> Frame -> Bool
<= :: Frame -> Frame -> Bool
$c<= :: Frame -> Frame -> Bool
< :: Frame -> Frame -> Bool
$c< :: Frame -> Frame -> Bool
compare :: Frame -> Frame -> Ordering
$ccompare :: Frame -> Frame -> Ordering
Ord, ReadPrec [Frame]
ReadPrec Frame
Int -> ReadS Frame
ReadS [Frame]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Frame]
$creadListPrec :: ReadPrec [Frame]
readPrec :: ReadPrec Frame
$creadPrec :: ReadPrec Frame
readList :: ReadS [Frame]
$creadList :: ReadS [Frame]
readsPrec :: Int -> ReadS Frame
$creadsPrec :: Int -> ReadS Frame
Read, Int -> Frame -> ShowS
[Frame] -> ShowS
Frame -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Frame] -> ShowS
$cshowList :: [Frame] -> ShowS
show :: Frame -> String
$cshow :: Frame -> String
showsPrec :: Int -> Frame -> ShowS
$cshowsPrec :: Int -> Frame -> ShowS
Show)

-- | The 'Stack' is used as a unique key for a unique call of a generator.
-- For instance, the cache uses it to cache generator output, and the random
-- mechanism uses it to permute 'Derive.EnvKey.seed'.  Since a single track
-- event may call multiple generators internally, each one is given a unique
-- serial number.
type Serial = Int

instance DeepSeq.NFData Frame where
    rnf :: Frame -> ()
rnf Frame
f = Frame
f seq :: forall a b. a -> b -> b
`seq` ()

instance Pretty Stack where
    format :: Stack -> Doc
format = forall a. Pretty a => [a] -> Doc
Pretty.formatList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
outermost

instance Pretty Frame where
    pretty :: Frame -> Text
pretty (Block BlockId
bid) = forall a. Show a => a -> Text
showt BlockId
bid
    pretty (Track TrackId
tid) = forall a. Show a => a -> Text
showt TrackId
tid
    pretty (Region TrackTime
s TrackTime
e) = forall a. Pretty a => a -> Text
pretty TrackTime
s forall a. Semigroup a => a -> a -> a
<> Text
"--" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TrackTime
e
    pretty (Call Text
call) = Text
call
    pretty (Serial Int
n) = forall a. Pretty a => a -> Text
pretty Int
n

instance Serialize.Serialize Frame where
    put :: Putter Frame
put Frame
frame = case Frame
frame of
        Block BlockId
bid -> Word8 -> Put
Serialize.put_tag Word8
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put BlockId
bid
        Track TrackId
tid -> Word8 -> Put
Serialize.put_tag Word8
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put TrackId
tid
        Region TrackTime
s TrackTime
e -> Word8 -> Put
Serialize.put_tag Word8
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put TrackTime
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put TrackTime
e
        Call Text
s -> Word8 -> Put
Serialize.put_tag Word8
4 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put Text
s
        Serial Int
n -> Word8 -> Put
Serialize.put_tag Word8
5 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put Int
n
    get :: Get Frame
get = do
        Word8
tag <- Get Word8
Serialize.get_tag
        case Word8
tag of
            Word8
0 -> do
                BlockId
bid :: BlockId <- forall a. Serialize a => Get a
Serialize.get
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BlockId -> Frame
Block BlockId
bid
            Word8
1 -> do
                TrackId
tid :: TrackId <- forall a. Serialize a => Get a
Serialize.get
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TrackId -> Frame
Track TrackId
tid
            Word8
2 -> do
                TrackTime
s :: TrackTime <- forall a. Serialize a => Get a
Serialize.get
                TrackTime
e :: TrackTime <- forall a. Serialize a => Get a
Serialize.get
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TrackTime -> TrackTime -> Frame
Region TrackTime
s TrackTime
e
            Word8
3 -> do
                String
s :: String <- forall a. Serialize a => Get a
Serialize.get
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Frame
Call (String -> Text
txt String
s)
            Word8
4 -> do
                Text
s :: Text <- forall a. Serialize a => Get a
Serialize.get
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Frame
Call Text
s
            Word8
5 -> do
                Int
n :: Int <- forall a. Serialize a => Get a
Serialize.get
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Frame
Serial Int
n
            Word8
_ -> forall a. String -> Word8 -> Get a
Serialize.bad_tag String
"Stack.Frame" Word8
tag

instance Seed.Seed Frame where
    to_seed :: Int -> Frame -> Int
to_seed Int
n = \case
        Block BlockId
block_id -> Int
n forall a. Seed a => Int -> a -> Int
Seed.& BlockId
block_id
        Track TrackId
track_id -> Int
n forall a. Num a => a -> a -> a
+ Int
1 forall a. Seed a => Int -> a -> Int
Seed.& TrackId
track_id
        Region TrackTime
s TrackTime
e -> Int
n forall a. Num a => a -> a -> a
+ Int
2 forall a. Seed a => Int -> a -> Int
Seed.& TrackTime
s forall a. Seed a => Int -> a -> Int
Seed.& TrackTime
e
        Call Text
call -> Int
n forall a. Num a => a -> a -> a
+ Int
3 forall a. Seed a => Int -> a -> Int
Seed.& Text
call
        Serial Int
i -> Int
n forall a. Num a => a -> a -> a
+ Int
4 forall a. Seed a => Int -> a -> Int
Seed.& Int
i

instance Aeson.ToJSON Frame where
    toJSON :: Frame -> Value
toJSON Frame
frame = Array -> Value
Aeson.Array forall a b. (a -> b) -> a -> b
$ case Frame
frame of
            Block BlockId
block_id -> Text -> Value -> Array
tagged Text
"Block" forall a b. (a -> b) -> a -> b
$
                forall a. ToJSON a => a -> Value
Aeson.toJSON forall a b. (a -> b) -> a -> b
$ forall a. Ident a => a -> Text
Id.ident_text BlockId
block_id
            Track TrackId
track_id -> Text -> Value -> Array
tagged Text
"Track" forall a b. (a -> b) -> a -> b
$
                forall a. ToJSON a => a -> Value
Aeson.toJSON forall a b. (a -> b) -> a -> b
$ forall a. Ident a => a -> Text
Id.ident_text TrackId
track_id
            Region TrackTime
s TrackTime
e -> Text -> Value -> Array
tagged Text
"Region" forall a b. (a -> b) -> a -> b
$
                forall a. ToJSON a => a -> Value
Aeson.toJSON (TrackTime -> Double
ScoreTime.to_double TrackTime
s, TrackTime -> Double
ScoreTime.to_double TrackTime
e)
            Call Text
text -> Text -> Value -> Array
tagged Text
"Call" (forall a. ToJSON a => a -> Value
Aeson.toJSON Text
text)
            Serial Int
n -> Text -> Value -> Array
tagged Text
"Serial" (forall a. ToJSON a => a -> Value
Aeson.toJSON Int
n)
        where tagged :: Text -> Value -> Array
tagged Text
name Value
val = forall a. [a] -> Vector a
Vector.fromList [Text -> Value
Aeson.String Text
name, Value
val]

instance Aeson.FromJSON Frame where
    parseJSON :: Value -> Parser Frame
parseJSON (Aeson.Array Array
a) = case forall a. Vector a -> [a]
Vector.toList Array
a of
        [Aeson.String Text
tag, Value
val]
            | Text
tag forall a. Eq a => a -> a -> Bool
== Text
"Block" ->
                BlockId -> Frame
Block forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> BlockId
Id.BlockId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Id
Id.read_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
val
            | Text
tag forall a. Eq a => a -> a -> Bool
== Text
"Track" ->
                TrackId -> Frame
Track forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> TrackId
Id.TrackId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Id
Id.read_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
val
            | Text
tag forall a. Eq a => a -> a -> Bool
== Text
"Region" -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TrackTime -> TrackTime -> Frame
Region
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Double -> TrackTime
ScoreTime.from_double Double -> TrackTime
ScoreTime.from_double forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
val
            | Text
tag forall a. Eq a => a -> a -> Bool
== Text
"Call" -> Text -> Frame
Call forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
val
            | Text
tag forall a. Eq a => a -> a -> Bool
== Text
"Serial" -> Int -> Frame
Serial forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
val
            | Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unknown tag: " forall a. Semigroup a => a -> a -> a
<> Text -> String
untxt Text
tag
        [Value]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting two element array"
    parseJSON Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting array"

format_ui :: Stack -> Pretty.Doc
format_ui :: Stack -> Doc
format_ui = [Text] -> Doc
Pretty.textList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map UiFrame -> Text
unparse_ui_frame forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [UiFrame]
to_ui

pretty_ui :: Stack -> Text
pretty_ui :: Stack -> Text
pretty_ui = Text -> [Text] -> Text
Text.intercalate Text
" / " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map UiFrame -> Text
unparse_ui_frame forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [UiFrame]
to_ui

pretty_ui_ :: Stack -> Text
pretty_ui_ :: Stack -> Text
pretty_ui_ = Text -> [Text] -> Text
Text.intercalate Text
" / " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map UiFrame -> Text
unparse_ui_frame_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [UiFrame]
to_ui

-- | Loggable msg with the last position of the stack.
pretty_ui_inner :: Stack -> Maybe Text
pretty_ui_inner :: Stack -> Maybe Text
pretty_ui_inner = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UiFrame -> Text
log_ui_frame forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [UiFrame]
to_ui_innermost

-- | Format a UiFrame for logging.  This means it wraps it in @{s "..."}@,
-- which causes logview to make it clickable, which will highlight the stack
-- location.
log_ui_frame :: UiFrame -> Text
log_ui_frame :: UiFrame -> Text
log_ui_frame UiFrame
frame = Text
"{s " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (UiFrame -> Text
unparse_ui_frame UiFrame
frame) forall a. Semigroup a => a -> a -> a
<> Text
"}"

-- * more specialized utils

-- | Get the Regions associated with a track in a given stack.  It's a little
-- tricky because track level calls will go in between the track and the
-- region, e.g. [track, call, call, region].
track_regions :: Stack -> TrackId -> [Ranges.Ranges TrackTime]
track_regions :: Stack -> TrackId -> [Ranges TrackTime]
track_regions Stack
stack TrackId
track_id =
    [forall n. n -> n -> Ranges n
Ranges.range TrackTime
s TrackTime
e | Frame
_ : [Frame]
rest <- [[Frame]]
groups, (TrackTime
s, TrackTime
e) <- [Frame] -> [(TrackTime, TrackTime)]
get_region [Frame]
rest ]
    where
    groups :: [[Frame]]
groups = forall a. (a -> Bool) -> [a] -> [[a]]
Lists.splitBefore (forall a. Eq a => a -> a -> Bool
== TrackId -> Frame
Track TrackId
track_id) (Stack -> [Frame]
outermost Stack
stack)
    get_region :: [Frame] -> [(TrackTime, TrackTime)]
get_region [Frame]
frames = case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Frame -> Bool
is_call [Frame]
frames of
        Region TrackTime
s TrackTime
e : [Frame]
_ -> [(TrackTime
s, TrackTime
e)]
        [Frame]
_ -> []
    is_call :: Frame -> Bool
is_call (Call {}) = Bool
True
    is_call Frame
_ = Bool
False
    -- find [track, call*, region] where the region overlaps

-- * ui

ui_match :: Pattern -> UiFrame -> Bool
ui_match :: Pattern -> UiFrame -> Bool
ui_match (Maybe BlockId
bid_pattern, Maybe (Set TrackId)
tids_pattern, Maybe (TrackTime, TrackTime)
range_pattern) (Maybe BlockId
bid, Maybe TrackId
tid, Maybe (TrackTime, TrackTime)
range) = forall (t :: * -> *). Foldable t => t Bool -> Bool
and
    [ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((forall a. Eq a => a -> a -> Bool
==Maybe BlockId
bid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) Maybe BlockId
bid_pattern
    , case (Maybe (Set TrackId)
tids_pattern, Maybe TrackId
tid) of
        (Just Set TrackId
tids, Just TrackId
tid) -> forall a. Ord a => a -> Set a -> Bool
Set.member TrackId
tid Set TrackId
tids
        (Maybe (Set TrackId)
Nothing, Maybe TrackId
_) -> Bool
True
        (Maybe (Set TrackId)
_, Maybe TrackId
Nothing) -> Bool
False
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (TrackTime, TrackTime) -> Bool
overlaps Maybe (TrackTime, TrackTime)
range_pattern
    ]
    where
    overlaps :: (TrackTime, TrackTime) -> Bool
overlaps (TrackTime
s, TrackTime
e) = case Maybe (TrackTime, TrackTime)
range of
        Maybe (TrackTime, TrackTime)
Nothing -> Bool
False
        Just (TrackTime
start, TrackTime
end) -> Bool -> Bool
not (TrackTime
end forall a. Ord a => a -> a -> Bool
<= TrackTime
s Bool -> Bool -> Bool
|| TrackTime
start forall a. Ord a => a -> a -> Bool
>= TrackTime
e)

-- | This is an abbreviation of the stack that only has elements that are
-- visible in the UI.
--
-- @(block_id, track_id, (event_start, event_end))@
type UiFrame = (Maybe BlockId, Maybe TrackId, Maybe (TrackTime, TrackTime))

-- | UiFrames are returned in outermost to innermost order.
to_ui :: Stack -> [UiFrame]
to_ui :: Stack -> [UiFrame]
to_ui = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [UiFrame]
to_ui_innermost

to_ui_innermost :: Stack -> [UiFrame]
to_ui_innermost :: Stack -> [UiFrame]
to_ui_innermost = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Frame -> [UiFrame] -> [UiFrame]
f [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
innermost
    where
    f :: Frame -> [UiFrame] -> [UiFrame]
f (Block BlockId
bid) [UiFrame]
accum = (forall a. a -> Maybe a
Just BlockId
bid, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing) forall a. a -> [a] -> [a]
: [UiFrame]
accum
    f (Track TrackId
tid) ((Maybe BlockId
bid, Maybe TrackId
_, Maybe (TrackTime, TrackTime)
_) : [UiFrame]
rest) = (Maybe BlockId
bid, forall a. a -> Maybe a
Just TrackId
tid, forall a. Maybe a
Nothing) forall a. a -> [a] -> [a]
: [UiFrame]
rest
    f (Region TrackTime
s TrackTime
e) ((Maybe BlockId
bid, tid :: Maybe TrackId
tid@(Just TrackId
_), Maybe (TrackTime, TrackTime)
_) : [UiFrame]
rest) =
        (Maybe BlockId
bid, Maybe TrackId
tid, forall a. a -> Maybe a
Just (TrackTime
s, TrackTime
e)) forall a. a -> [a] -> [a]
: [UiFrame]
rest
    f Frame
_ [UiFrame]
accum = [UiFrame]
accum

-- | These functions are used by LogView and Cmd.Repl.*, but are here since
-- both places import this module.  Examples:
--
-- > "untitled/b0 untitled/b0.t2 0-.25"
-- > "untitled/b0 foo/bar *"
-- > "untitled/b0 * *"
unparse_ui_frame :: UiFrame -> Text
unparse_ui_frame :: UiFrame -> Text
unparse_ui_frame (Maybe BlockId
maybe_bid, Maybe TrackId
maybe_tid, Maybe (TrackTime, TrackTime)
maybe_range) =
    Text -> [Text] -> Text
Text.intercalate Text
" " [Text
bid_s, Text
tid_s, Text
range_s]
    where
    bid_s :: Text
bid_s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"*" (Id -> Text
Id.show_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ident a => a -> Id
Id.unpack_id) Maybe BlockId
maybe_bid
    tid_s :: Text
tid_s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"*" (Id -> Text
Id.show_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ident a => a -> Id
Id.unpack_id) Maybe TrackId
maybe_tid
    range_s :: Text
range_s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"*"
        (\(TrackTime
from, TrackTime
to) -> TrackTime -> Text
float TrackTime
from forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> TrackTime -> Text
float TrackTime
to) Maybe (TrackTime, TrackTime)
maybe_range
    float :: TrackTime -> Text
float = forall a. RealFloat a => Int -> a -> Text
Num.showFloat Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> Double
ScoreTime.to_double

-- | This is like 'unparse_ui_frame' except it omits the namespaces for a less
-- cluttered but potentially ambiguous output.
unparse_ui_frame_ :: UiFrame -> Text
unparse_ui_frame_ :: UiFrame -> Text
unparse_ui_frame_ (Maybe BlockId
maybe_bid, Maybe TrackId
maybe_tid, Maybe (TrackTime, TrackTime)
maybe_range) =
    [Text] -> Text
Text.unwords [Text
bid_s, Text
tid_s, Text
range_s]
    where
    bid_s :: Text
bid_s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"*" forall a. Ident a => a -> Text
Id.ident_name Maybe BlockId
maybe_bid
    tid_s :: Text
tid_s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"*" forall a. Ident a => a -> Text
Id.ident_name Maybe TrackId
maybe_tid
    range_s :: Text
range_s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"*"
        (\(TrackTime
from, TrackTime
to) -> TrackTime -> Text
float TrackTime
from forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> TrackTime -> Text
float TrackTime
to) Maybe (TrackTime, TrackTime)
maybe_range
    float :: TrackTime -> Text
float = forall a. RealFloat a => Int -> a -> Text
Num.showFloat Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> Double
ScoreTime.to_double

parse_ui_frame :: String -> Maybe UiFrame
parse_ui_frame :: String -> Maybe UiFrame
parse_ui_frame = forall a. Parser a -> String -> Maybe a
ParseText.maybe_parse_string forall a b. (a -> b) -> a -> b
$ do
    Maybe Text
bid <- forall {a}. Parser Text a -> Parser Text (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
ParseText.lexeme Parser Text
ParseText.p_word
    Maybe Text
tid <- forall {a}. Parser Text a -> Parser Text (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser a
ParseText.lexeme Parser Text
ParseText.p_word
    Maybe (TrackTime, TrackTime)
range <- forall {a}. Parser Text a -> Parser Text (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ do
        Double
from <- Parser Double
ParseText.p_float
        Char -> Parser Char
A.char Char
'-'
        Double
to <- Parser Double
ParseText.p_float
        forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> TrackTime
ScoreTime.from_double Double
from, Double -> TrackTime
ScoreTime.from_double Double
to)
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( Id -> BlockId
Id.BlockId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Id
Id.read_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
bid
        , Id -> TrackId
Id.TrackId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Id
Id.read_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
tid
        , Maybe (TrackTime, TrackTime)
range
        )
    where
    optional :: Parser Text a -> Parser Text (Maybe a)
optional Parser Text a
p = (Char -> Parser Char
A.char Char
'*' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text ()
A.skipSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just Parser Text a
p