-- Copyright 2021 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
module Ui.Meter.Mark (
    Marklist, MarklistVector
    , marklist, marklist_from_vector
    , empty
    , to_list
    , ascending, descending
    , end, start
    , insert_mark
    , Mark(..)
    , Label

    -- * for RulerC's eyes only
    , MarklistPtr(..)
    , marklist_vec, marklist_fptr
) where
import qualified Control.Concurrent.MVar as MVar
import qualified Control.DeepSeq as DeepSeq
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Foreign
import qualified System.IO.Unsafe as Unsafe

import qualified Util.TimeVector as TimeVector
import qualified Perform.RealTime as RealTime
import qualified Ui.Color as Color
import qualified Ui.Meter.Meter as Meter

import           Global
import           Types


data Marklist = Marklist
    { Marklist -> MarklistVector
marklist_vec :: !MarklistVector
    -- | This is a cache for the C-marshalled version of the marklist.
    -- It will be allocated if the Marklist is passed to C, and is managed with
    -- its own reference count.
    --
    -- I think this should be safe as long as 'marklist' is the only
    -- constructor.
    , Marklist -> MarklistPtr
marklist_fptr :: !MarklistPtr
    }

type MarklistVector = TimeVector.Boxed Mark

instance Eq Marklist where
    Marklist
m1 == :: Marklist -> Marklist -> Bool
== Marklist
m2 = Marklist -> MarklistVector
marklist_vec Marklist
m1 forall a. Eq a => a -> a -> Bool
== Marklist -> MarklistVector
marklist_vec Marklist
m2
instance Show Marklist where
    show :: Marklist -> String
show Marklist
m = String
"Ruler.marklist " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ScoreTime -> Marklist -> [PosMark]
ascending ScoreTime
0 Marklist
m)
instance Pretty Marklist where
    pretty :: Marklist -> Text
pretty Marklist
m = Text
"((" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (v :: * -> *) a. Vector v a => v a -> Int
TimeVector.length (Marklist -> MarklistVector
marklist_vec Marklist
m)) forall a. Semigroup a => a -> a -> a
<> Text
" marks))"

-- | This should be opaque, but it needs to be exported for RulerC.  Don't look
-- inside if you're not RulerC, OK?
--
-- The Left value is actually not used, but prevents the unsafePerformIO from
-- being floated out of the lambda.
--
-- I used to just copy the ruler each time, but it was actually pretty big.
-- Rulers can have lots of marks, there are many rulers per block since each
-- track has one.  But many tracks share the same ruler, and they change
-- rarely.  All of these differences from 'Events.Events' push for passing
-- by pointer rather than copying over the whole thing each time (as with the
-- signal), or passing a callback that fetches the required range (as with
-- events).
--
-- TODO I could share the memory by making MarklistVector into Vector.Storable
-- PosMark.  It's otherwise equivalant though, and the number of distinct
-- rulers is probably small, so the memory savings doesn't seem that
-- compelling.
newtype MarklistPtr = MarklistPtr
    (MVar.MVar (Either MarklistVector (Foreign.ForeignPtr Marklist)))
type PosMark = (ScoreTime, Mark)

marklist :: [PosMark] -> Marklist
marklist :: [PosMark] -> Marklist
marklist = MarklistVector -> Marklist
marklist_from_vector forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) y.
Vector v (Sample y) =>
[(X, y)] -> v (Sample y)
TimeVector.from_pairs
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ScoreTime -> X
RealTime.from_score)

{-# NOINLINE marklist_from_vector #-} -- due to evil unsafePerformIO
marklist_from_vector :: MarklistVector -> Marklist
marklist_from_vector :: MarklistVector -> Marklist
marklist_from_vector MarklistVector
vec = Marklist
    { marklist_vec :: MarklistVector
marklist_vec = MarklistVector
vec
    , marklist_fptr :: MarklistPtr
marklist_fptr = MVar (Either MarklistVector (ForeignPtr Marklist)) -> MarklistPtr
MarklistPtr forall a b. (a -> b) -> a -> b
$ forall a. IO a -> a
Unsafe.unsafePerformIO forall a b. (a -> b) -> a -> b
$
        forall a. a -> IO (MVar a)
MVar.newMVar (forall a b. a -> Either a b
Left MarklistVector
vec)
    }

empty :: Marklist
empty :: Marklist
empty = [PosMark] -> Marklist
marklist forall a. Monoid a => a
mempty

to_list :: Marklist -> [PosMark]
to_list :: Marklist -> [PosMark]
to_list = forall a b. (a -> b) -> [a] -> [b]
map Sample Mark -> PosMark
unsample forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) a. Vector v a => v a -> [a]
TimeVector.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Marklist -> MarklistVector
marklist_vec

-- | Marks starting at the first mark >= the given pos, to the end.
ascending :: ScoreTime -> Marklist -> [PosMark]
ascending :: ScoreTime -> Marklist -> [PosMark]
ascending ScoreTime
pos Marklist
mlist = forall a b. (a -> b) -> [a] -> [b]
map Sample Mark -> PosMark
unsample forall a b. (a -> b) -> a -> b
$
    forall (v :: * -> *) y.
Vector v (Sample y) =>
X -> v (Sample y) -> [Sample y]
TimeVector.ascending (ScoreTime -> X
RealTime.from_score ScoreTime
pos) (Marklist -> MarklistVector
marklist_vec Marklist
mlist)

-- | Marks starting at the first mark below the given pos, to the beginning.
descending :: ScoreTime -> Marklist -> [PosMark]
descending :: ScoreTime -> Marklist -> [PosMark]
descending ScoreTime
pos Marklist
mlist = forall a b. (a -> b) -> [a] -> [b]
map Sample Mark -> PosMark
unsample forall a b. (a -> b) -> a -> b
$
    forall (v :: * -> *) y.
Vector v (Sample y) =>
X -> v (Sample y) -> [Sample y]
TimeVector.descending (ScoreTime -> X
RealTime.from_score ScoreTime
pos) (Marklist -> MarklistVector
marklist_vec Marklist
mlist)

unsample :: TimeVector.Sample Mark -> PosMark
unsample :: Sample Mark -> PosMark
unsample Sample Mark
s = (X -> ScoreTime
RealTime.to_score (forall y. Sample y -> X
TimeVector.sx Sample Mark
s), forall y. Sample y -> y
TimeVector.sy Sample Mark
s)

-- | Get the position of the last mark.
end :: Marklist -> ScoreTime
end :: Marklist -> ScoreTime
end = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ScoreTime
0 (X -> ScoreTime
RealTime.to_score forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall y. Sample y -> X
TimeVector.sx)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) a. Vector v a => v a -> Maybe a
TimeVector.last forall b c a. (b -> c) -> (a -> b) -> a -> c
. Marklist -> MarklistVector
marklist_vec

start :: Marklist -> ScoreTime
start :: Marklist -> ScoreTime
start = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ScoreTime
0 (X -> ScoreTime
RealTime.to_score forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall y. Sample y -> X
TimeVector.sx)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) a. Vector v a => v a -> Maybe a
TimeVector.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Marklist -> MarklistVector
marklist_vec

insert_mark :: ScoreTime -> Mark -> Marklist -> Marklist
insert_mark :: ScoreTime -> Mark -> Marklist -> Marklist
insert_mark ScoreTime
pos Mark
mark = [PosMark] -> Marklist
marklist forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> a -> [a] -> [a]
List.insertBy forall {a} {b} {b}. Ord a => (a, b) -> (a, b) -> Ordering
cmp (ScoreTime
pos, Mark
mark) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Marklist -> [PosMark]
ascending ScoreTime
0
    where cmp :: (a, b) -> (a, b) -> Ordering
cmp (a, b)
a (a, b)
b = forall a. Ord a => a -> a -> Ordering
compare (forall a b. (a, b) -> a
fst (a, b)
a) (forall a b. (a, b) -> a
fst (a, b)
b)

-- * mark

data Mark = Mark {
    -- | An arbitrary low integer.  This is the only part of the mark that
    -- matters to the code, the rest is purely visual.  By convention, the
    -- most prominent divisions start at rank 0 and go up from there.
    Mark -> Rank
mark_rank :: !Meter.Rank
    -- | Width in pixels.
    , Mark -> Int
mark_width :: !Int
    , Mark -> Color
mark_color :: !Color.Color
    -- | A bit of text displayed with the mark.  This can use backtick symbols.
    , Mark -> Text
mark_name :: !Label
    -- | The text is only displayed when the zoom factor exceeds this value.
    , Mark -> Double
mark_name_zoom_level :: !Double
    -- | The mark itself is only displayed when the zoom factor exeeds this
    -- value.
    , Mark -> Double
mark_zoom_level :: !Double
    } deriving (Mark -> Mark -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mark -> Mark -> Bool
$c/= :: Mark -> Mark -> Bool
== :: Mark -> Mark -> Bool
$c== :: Mark -> Mark -> Bool
Eq, Int -> Mark -> ShowS
[Mark] -> ShowS
Mark -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mark] -> ShowS
$cshowList :: [Mark] -> ShowS
show :: Mark -> String
$cshow :: Mark -> String
showsPrec :: Int -> Mark -> ShowS
$cshowsPrec :: Int -> Mark -> ShowS
Show)

type Label = Text

instance DeepSeq.NFData Mark where
    rnf :: Mark -> ()
rnf (Mark Rank
rank Int
width Color
color Text
name Double
name_zoom Double
zoom) = Rank
rank seq :: forall a b. a -> b -> b
`seq` Int
width
        seq :: forall a b. a -> b -> b
`seq` Color
color seq :: forall a b. a -> b -> b
`seq` Text
name seq :: forall a b. a -> b -> b
`seq` Double
name_zoom seq :: forall a b. a -> b -> b
`seq` Double
zoom seq :: forall a b. a -> b -> b
`seq` ()

instance Pretty Mark where
    pretty :: Mark -> Text
pretty Mark
m = Text
"(mark " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Mark -> Rank
mark_rank Mark
m) forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
")"
        where name :: Text
name = if Text -> Bool
Text.null (Mark -> Text
mark_name Mark
m) then Text
"" else Text
" " forall a. Semigroup a => a -> a -> a
<> Mark -> Text
mark_name Mark
m