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

-- | Utilities to create a non-colliding Id, using the standard naming scheme.
-- It should be passed to the apppropriate create funciton, e.g.
-- 'Ui.create_block' to make a BlockId.
module Ui.GenId where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text

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

import Global
import Types


view_id :: Ui.M m => BlockId -> m Id.Id
view_id :: forall (m :: * -> *). M m => BlockId -> m Id
view_id BlockId
block_id =
    forall (m :: * -> *) a. M m => Text -> Maybe a -> m a
require_id Text
"view id" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. BlockId -> Map ViewId a -> Maybe Id
generate_view_id BlockId
block_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map ViewId View
Ui.state_views

block_id :: Ui.M m => Maybe BlockId -> m Id.Id
block_id :: forall (m :: * -> *). M m => Maybe BlockId -> m Id
block_id Maybe BlockId
maybe_parent = do
    Namespace
ns <- forall (m :: * -> *). M m => m Namespace
Ui.get_namespace
    forall (m :: * -> *) a. M m => Text -> Maybe a -> m a
require_id Text
"block id" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe BlockId -> Namespace -> Map BlockId a -> Maybe Id
generate_block_id Maybe BlockId
maybe_parent Namespace
ns
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks

track_id :: Ui.M m => BlockId -> m Id.Id
track_id :: forall (m :: * -> *). M m => BlockId -> m Id
track_id BlockId
block_id = forall (m :: * -> *) a. M m => Text -> Maybe a -> m a
require_id Text
"track id" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. BlockId -> Map TrackId a -> Maybe Id
generate_track_id BlockId
block_id
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map TrackId Track
Ui.state_tracks

-- | ViewIds look like \"ns/b0.v0\", \"ns/b0.v1\", etc.
generate_view_id :: BlockId -> Map ViewId a -> Maybe Id.Id
generate_view_id :: forall a. BlockId -> Map ViewId a -> Maybe Id
generate_view_id BlockId
bid Map ViewId a
views =
    forall a b.
Ord a =>
Namespace -> Id -> Text -> (Id -> a) -> Map a b -> Maybe Id
generate_id (Id -> Namespace
Id.id_namespace Id
ident) Id
ident Text
"v" Id -> ViewId
Id.ViewId Map ViewId a
views
    where ident :: Id
ident = forall a. Ident a => a -> Id
Id.unpack_id BlockId
bid

generate_block_id :: Maybe BlockId -> Id.Namespace -> Map BlockId a
    -> Maybe Id.Id
generate_block_id :: forall a. Maybe BlockId -> Namespace -> Map BlockId a -> Maybe Id
generate_block_id Maybe BlockId
maybe_parent Namespace
ns Map BlockId a
blocks =
    forall a b.
Ord a =>
Namespace -> Id -> Text -> (Id -> a) -> Map a b -> Maybe Id
generate_id Namespace
ns Id
parent Text
"b" Id -> BlockId
Id.BlockId Map BlockId a
blocks
    where parent :: Id
parent = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Id
Id.global Text
"") forall a. Ident a => a -> Id
Id.unpack_id Maybe BlockId
maybe_parent

generate_track_id :: BlockId -> Map TrackId a -> Maybe Id.Id
generate_track_id :: forall a. BlockId -> Map TrackId a -> Maybe Id
generate_track_id BlockId
bid Map TrackId a
tracks =
    forall a b.
Ord a =>
Namespace -> Id -> Text -> (Id -> a) -> Map a b -> Maybe Id
generate_id (Id -> Namespace
Id.id_namespace Id
ident) Id
ident Text
"t" Id -> TrackId
Id.TrackId Map TrackId a
tracks
    where ident :: Id
ident = forall a. Ident a => a -> Id
Id.unpack_id BlockId
bid

generate_id :: Ord a => Id.Namespace -> Id.Id -> Text -> (Id.Id -> a)
    -> Map a b -> Maybe Id.Id
generate_id :: forall a b.
Ord a =>
Namespace -> Id -> Text -> (Id -> a) -> Map a b -> Maybe Id
generate_id Namespace
ns Id
parent_id Text
code Id -> a
typ Map a b
fm =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map a b
fm) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> a
typ) [Id]
candidates
    where candidates :: [Id]
candidates = Namespace -> Text -> Text -> [Id]
ids_for Namespace
ns (Id -> Text
Id.id_name Id
parent_id) Text
code

-- | Guess a TrackId generated from GenId.  Useful for tests.
track_id_at :: BlockId -> TrackNum -> TrackId
track_id_at :: BlockId -> Int -> TrackId
track_id_at BlockId
bid Int
tracknum = Id -> TrackId
Id.TrackId forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Text -> Int -> Id
id_at Namespace
ns Text
ident Text
"t" Int
tracknum
    where (Namespace
ns, Text
ident) = Id -> (Namespace, Text)
Id.un_id forall a b. (a -> b) -> a -> b
$ forall a. Ident a => a -> Id
Id.unpack_id BlockId
bid

-- | IDs are numbered, and they start at 1 instead of 0.
--
-- This is because usually tracknum 0 is the ruler, so counting with tracknums,
-- event tracks start at 1.  The actual TrackId should be irrelevant (and would
-- be out of date as soon as a track is swapped), but for testing it's very
-- convenient if they line up with the tracknums.  So even though it's purely
-- for testing and only for TrackIds, I start everything at 1 just for
-- consistency.
ids_for :: Id.Namespace -> Text -> Text -> [Id.Id]
ids_for :: Namespace -> Text -> Text -> [Id]
ids_for Namespace
ns Text
parent Text
code = forall a b. (a -> b) -> [a] -> [b]
map (Namespace -> Text -> Text -> Int -> Id
id_at Namespace
ns Text
parent Text
code) [Int
1..]

id_at :: Id.Namespace -> Text -> Text -> Int -> Id.Id
id_at :: Namespace -> Text -> Text -> Int -> Id
id_at Namespace
ns Text
parent Text
code Int
n =
    Namespace -> Text -> Id
Id.id Namespace
ns (Text -> Text
dotted Text
parent forall a. Semigroup a => a -> a -> a
<> Text
code forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
n)
    where dotted :: Text -> Text
dotted Text
s = if Text -> Bool
Text.null Text
s then Text
"" else Text
s forall a. Semigroup a => a -> a -> a
<> Text
"."

require_id :: Ui.M m => Text -> Maybe a -> m a
require_id :: forall (m :: * -> *) a. M m => Text -> Maybe a -> m a
require_id Text
msg = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw forall a b. (a -> b) -> a -> b
$ Text
"somehow can't find ID for " forall a. Semigroup a => a -> a -> a
<> Text
msg) forall (m :: * -> *) a. Monad m => a -> m a
return