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

-- | Utilities to modify events in tracks.
module Cmd.ModifyEvents where
import qualified Data.Either as Either
import qualified Data.IntMap as IntMap
import qualified Data.List as List
import qualified Data.String as String
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Selection as Selection
import qualified Derive.Parse as Parse
import qualified Derive.ParseTitle as ParseTitle
import qualified Ui.Block as Block
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Sel as Sel
import qualified Ui.Ui as Ui

import           Global
import           Types


-- | Map a function over multiple tracks.  It has access to all selected
-- events.  Omit a TrackId from the output to leave it unchanged.
type Tracks m = BlockId -> [(TrackId, [Event.Event])]
    -> m [(TrackId, [Event.Event])]

-- | Map a function over events on a certain track.  Returning Nothing will
-- leave the track unchanged.
type Track m = BlockId -> TrackId -> [Event.Event] -> m (Maybe [Event.Event])

-- | Map a Track transformer over multiple tracks.
track :: Monad m => Track m -> Tracks m
track :: forall (m :: * -> *). Monad m => Track m -> Tracks m
track Track m
modify = \BlockId
block_id [(TrackId, [Event])]
track_events -> do
    [Maybe [Event]]
outs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Track m
modify BlockId
block_id)) [(TrackId, [Event])]
track_events
    forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (TrackId
track_id, [Event]
events)
        | (TrackId
track_id, Just [Event]
events) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TrackId, [Event])]
track_events) [Maybe [Event]]
outs
        ]

-- | Map a function over a set of events.
events :: Monad m => ([Event.Event] -> m [Event.Event]) -> Track m
events :: forall (m :: * -> *). Monad m => ([Event] -> m [Event]) -> Track m
events [Event] -> m [Event]
f BlockId
_ TrackId
_ = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> m [Event]
f

-- | Map a function over a single event.
event :: Monad m => (Event.Event -> Event.Event) -> Track m
event :: forall (m :: * -> *). Monad m => (Event -> Event) -> Track m
event Event -> Event
f = forall (m :: * -> *). Monad m => ([Event] -> m [Event]) -> Track m
events (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Event -> Event
f)

text :: Monad m => (Text -> Text) -> Track m
text :: forall (m :: * -> *). Monad m => (Token -> Token) -> Track m
text = forall (m :: * -> *). Monad m => (Event -> Event) -> Track m
event forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Token -> Token
f -> Lens Event Token
Event.text_ forall f a. Lens f a -> (a -> a) -> f -> f
%= Token -> Token
f)

-- | Split up a pipeline and lex the calls.
pipeline :: ([[Text]] -> [[Text]]) -> Text -> Text
pipeline :: ([[Token]] -> [[Token]]) -> Token -> Token
pipeline [[Token]] -> [[Token]]
modify = [[Token]] -> Token
Parse.join_pipeline forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Token]] -> [[Token]]
modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> [[Token]]
Parse.split_pipeline

-- | Take a text transformation that can fail to a Track transformation that
-- transforms all the events and throws if any of the text transformations
-- failed.
failable_text :: Cmd.M m => (Text -> Either Text Text) -> Track m
failable_text :: forall (m :: * -> *).
M m =>
(Token -> Either Token Token) -> Track m
failable_text Token -> Either Token Token
f BlockId
block_id TrackId
track_id [Event]
events = do
    let ([(Token, Event)]
failed, [Event]
ok) = forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {a}.
(Token -> Either a Token) -> Event -> Either (a, Event) Event
failing_text Token -> Either Token Token
f) [Event]
events
        errs :: [Token]
errs = [Token
err forall a. Semigroup a => a -> a -> a
<> Token
": " forall a. Semigroup a => a -> a -> a
<> BlockId -> TrackId -> Event -> Token
Cmd.log_event BlockId
block_id TrackId
track_id Event
evt
            | (Token
err, Event
evt) <- [(Token, Event)]
failed]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
errs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (Stack, M m) => Token -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$
        Token
"transformation failed: " forall a. Semigroup a => a -> a -> a
<> Token -> [Token] -> Token
Text.intercalate Token
", " [Token]
errs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Event]
ok
    where
    failing_text :: (Token -> Either a Token) -> Event -> Either (a, Event) Event
failing_text Token -> Either a Token
f Event
event = case Token -> Either a Token
f (Event -> Token
Event.text Event
event) of
        Left a
err -> forall a b. a -> Either a b
Left (a
err, Event
event)
        Right Token
text -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Lens Event Token
Event.text_ forall f a. Lens f a -> a -> f -> f
#= Token
text forall a b. (a -> b) -> a -> b
$ Event
event


-- * modify selections

selection_tracks :: Cmd.M m => Tracks m -> m ()
selection_tracks :: forall (m :: * -> *). M m => Tracks m -> m ()
selection_tracks Tracks m
modify =
    forall (m :: * -> *).
M m =>
Collapsed -> Tracks m -> [(TrackId, [Event])] -> m ()
modify_selected Collapsed
IncludeCollapsed Tracks m
modify forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m [(TrackId, [Event])]
Selection.events

-- | Map a function over the selected events, as per 'Selection.events'.
selection :: Cmd.M m => Track m -> m ()
selection :: forall (m :: * -> *). M m => Track m -> m ()
selection Track m
modify =
    forall (m :: * -> *).
M m =>
Collapsed -> Tracks m -> [(TrackId, [Event])] -> m ()
modify_selected Collapsed
IncludeCollapsed (forall (m :: * -> *). Monad m => Track m -> Tracks m
track Track m
modify) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m [(TrackId, [Event])]
Selection.events

-- | Like 'selection', but don't apply to collapsed tracks.  This is
-- appropriate for operations that often apply to note tracks.  If you select
-- multiple note tracks, then the intervening collapsed pitch tracks will also
-- be selected and if you accidentally modify those you won't see the
-- modifications.
selection_visible :: Cmd.M m => Track m -> m ()
selection_visible :: forall (m :: * -> *). M m => Track m -> m ()
selection_visible Track m
modify = forall (m :: * -> *). M m => Track m -> Context -> m ()
ctx_selection_visible Track m
modify forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m Context
Selection.context

ctx_selection_visible :: Ui.M m => Track m -> Selection.Context -> m ()
ctx_selection_visible :: forall (m :: * -> *). M m => Track m -> Context -> m ()
ctx_selection_visible Track m
modify Context
ctx =
    forall (m :: * -> *).
M m =>
Collapsed -> Tracks m -> BlockId -> [(TrackId, [Event])] -> m ()
modify_selected_block Collapsed
ExcludeCollapsed (forall (m :: * -> *). Monad m => Track m -> Tracks m
track Track m
modify)
        (Context -> BlockId
Selection.ctx_block_id Context
ctx) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => Context -> m [(TrackId, [Event])]
Selection.ctx_events Context
ctx

-- | Like 'selection', but only operate on the 'Selection.point_track'.
selected_track :: Cmd.M m => Track m -> m ()
selected_track :: forall (m :: * -> *). M m => Track m -> m ()
selected_track Track m
modify =
    forall (m :: * -> *).
M m =>
Collapsed -> Tracks m -> [(TrackId, [Event])] -> m ()
modify_selected Collapsed
ExcludeCollapsed (forall (m :: * -> *). Monad m => Track m -> Tracks m
track Track m
modify) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (TrackId, [Event])
Selection.track_events
    -- Don't affect collapsed tracks because why would the point selection be
    -- on one of those?

data Collapsed = ExcludeCollapsed | IncludeCollapsed
    deriving (Int -> Collapsed -> ShowS
[Collapsed] -> ShowS
Collapsed -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Collapsed] -> ShowS
$cshowList :: [Collapsed] -> ShowS
show :: Collapsed -> String
$cshow :: Collapsed -> String
showsPrec :: Int -> Collapsed -> ShowS
$cshowsPrec :: Int -> Collapsed -> ShowS
Show, Collapsed -> Collapsed -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Collapsed -> Collapsed -> Bool
$c/= :: Collapsed -> Collapsed -> Bool
== :: Collapsed -> Collapsed -> Bool
$c== :: Collapsed -> Collapsed -> Bool
Eq)

modify_selected :: Cmd.M m => Collapsed
    -> Tracks m -> Selection.SelectedEvents -> m ()
modify_selected :: forall (m :: * -> *).
M m =>
Collapsed -> Tracks m -> [(TrackId, [Event])] -> m ()
modify_selected Collapsed
collapsed Tracks m
modify [(TrackId, [Event])]
selected = do
    BlockId
block_id <- forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    forall (m :: * -> *).
M m =>
Collapsed -> Tracks m -> BlockId -> [(TrackId, [Event])] -> m ()
modify_selected_block Collapsed
collapsed Tracks m
modify BlockId
block_id [(TrackId, [Event])]
selected

-- It would be nice to make this a ctx_ function, but modify_selected is called
-- with different selections.
modify_selected_block :: Ui.M m => Collapsed
    -> Tracks m -> BlockId -> Selection.SelectedEvents -> m ()
modify_selected_block :: forall (m :: * -> *).
M m =>
Collapsed -> Tracks m -> BlockId -> [(TrackId, [Event])] -> m ()
modify_selected_block Collapsed
collapsed Tracks m
modify BlockId
block_id [(TrackId, [Event])]
selected = do
    [(TrackId, [Event])]
selected <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall {m :: * -> *}. M m => TrackId -> m Bool
wanted forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(TrackId, [Event])]
selected
    [(TrackId, [Event])]
new <- Tracks m
modify BlockId
block_id [(TrackId, [Event])]
selected
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TrackId, [Event])]
new forall a b. (a -> b) -> a -> b
$ \(TrackId
track_id, [Event]
new_events) -> do
        let events :: [Event]
events = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TrackId
track_id [(TrackId, [Event])]
selected
        forall (m :: * -> *). M m => TrackId -> [Event] -> m ()
Ui.remove_events TrackId
track_id [Event]
events
        forall (m :: * -> *). M m => BlockId -> TrackId -> [Event] -> m ()
Ui.insert_block_events BlockId
block_id TrackId
track_id [Event]
new_events
    where
    wanted :: TrackId -> m Bool
wanted TrackId
track_id = case Collapsed
collapsed of
        Collapsed
IncludeCollapsed -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Collapsed
ExcludeCollapsed -> do
            Int
tracknum <- forall (m :: * -> *). M m => BlockId -> TrackId -> m Int
Ui.get_tracknum_of BlockId
block_id TrackId
track_id
            Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> Int -> m Bool
Ui.track_collapsed BlockId
block_id Int
tracknum

-- | Advance the selection if it was a point.  This is convenient for applying
-- a transformation repeatedly.
advance_if_point :: Cmd.M m => m ()
advance_if_point :: forall (m :: * -> *). M m => m ()
advance_if_point = forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Selection -> Bool
Sel.is_point forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m Selection
Selection.get) forall (m :: * -> *). M m => m ()
Selection.advance

-- | Map a function over the events that overlap the selection point.
overlapping :: Cmd.M m => Track m -> m ()
overlapping :: forall (m :: * -> *). M m => Track m -> m ()
overlapping Track m
f = do
    (BlockId
block_id, [Int]
_, [TrackId]
track_ids, Range
_) <- forall (m :: * -> *). M m => m (BlockId, [Int], [TrackId], Range)
Selection.tracks
    TrackTime
pos <- forall (m :: * -> *). M m => m TrackTime
Selection.point
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TrackId]
track_ids forall a b. (a -> b) -> a -> b
$ \TrackId
track_id -> do
        Maybe Event
maybe_event <- TrackTime -> Events -> Maybe Event
Events.overlapping TrackTime
pos 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
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Event
maybe_event forall a b. (a -> b) -> a -> b
$ \Event
old_event ->
            forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (Track m
f BlockId
block_id TrackId
track_id [Event
old_event]) forall a b. (a -> b) -> a -> b
$ \[Event]
new_events -> do
                forall (m :: * -> *). M m => TrackId -> Event -> m ()
Ui.remove_event TrackId
track_id Event
old_event
                forall (m :: * -> *). M m => BlockId -> TrackId -> [Event] -> m ()
Ui.insert_block_events BlockId
block_id TrackId
track_id [Event]
new_events

-- | Map over tracks whose name matches the predicate.
tracks_named :: Cmd.M m => (Text -> Bool) -> Track m -> Track m
tracks_named :: forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> Track m
tracks_named Token -> Bool
wanted Track m
f = \BlockId
block_id TrackId
track_id [Event]
events ->
    forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Token -> Bool
wanted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => TrackId -> m Token
Ui.get_track_title TrackId
track_id)
        (Track m
f BlockId
block_id TrackId
track_id [Event]
events) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)

selected_note :: Cmd.M m => Track m -> m ()
selected_note :: forall (m :: * -> *). M m => Track m -> m ()
selected_note = forall (m :: * -> *). M m => Track m -> m ()
selection forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> Track m
tracks_named Token -> Bool
ParseTitle.is_note_track

selected_control :: Cmd.M m => Track m -> m ()
selected_control :: forall (m :: * -> *). M m => Track m -> m ()
selected_control = forall (m :: * -> *). M m => Track m -> m ()
selection forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> Track m
tracks_named Token -> Bool
ParseTitle.is_signal_track

selected_pitch :: Cmd.M m => Track m -> m ()
selected_pitch :: forall (m :: * -> *). M m => Track m -> m ()
selected_pitch = forall (m :: * -> *). M m => Track m -> m ()
selection forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> Track m
tracks_named Token -> Bool
ParseTitle.is_pitch_track


-- * block tracks

-- | Like 'selection', but maps over an entire block.
block :: Cmd.M m => BlockId -> Track m -> m ()
block :: forall (m :: * -> *). M m => BlockId -> Track m -> m ()
block BlockId
block_id Track m
f = do
    [TrackId]
track_ids <- Block -> [TrackId]
Block.block_track_ids forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TrackId]
track_ids forall a b. (a -> b) -> a -> b
$ \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
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *). M m => TrackId -> (Events -> Events) -> m ()
Ui.modify_events TrackId
track_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Events
Events.from_list)
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Track m
f BlockId
block_id TrackId
track_id [Event]
events

all_blocks :: Cmd.M m => Track m -> m ()
all_blocks :: forall (m :: * -> *). M m => Track m -> m ()
all_blocks Track m
f = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *). M m => BlockId -> Track m -> m ()
block Track m
f) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m [BlockId]
Ui.all_block_ids

all_tracks_named :: Cmd.M m => (Text -> Bool) -> Track m -> m ()
all_tracks_named :: forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> m ()
all_tracks_named Token -> Bool
wanted = forall (m :: * -> *). M m => Track m -> m ()
all_blocks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> Track m
tracks_named Token -> Bool
wanted

note_tracks :: Cmd.M m => Track m -> m ()
note_tracks :: forall (m :: * -> *). M m => Track m -> m ()
note_tracks = forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> m ()
all_tracks_named Token -> Bool
ParseTitle.is_note_track

control_tracks :: Cmd.M m => Track m -> m ()
control_tracks :: forall (m :: * -> *). M m => Track m -> m ()
control_tracks = forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> m ()
all_tracks_named Token -> Bool
ParseTitle.is_control_track

pitch_tracks :: Cmd.M m => Track m -> m ()
pitch_tracks :: forall (m :: * -> *). M m => Track m -> m ()
pitch_tracks = forall (m :: * -> *). M m => (Token -> Bool) -> Track m -> m ()
all_tracks_named Token -> Bool
ParseTitle.is_pitch_track

-- * misc

-- | Move everything at or after @start@ by @shift@.
move_track_events :: Ui.M m => ScoreTime -> ScoreTime -> ScoreTime
    -> TrackId -> m ()
move_track_events :: forall (m :: * -> *).
M m =>
TrackTime -> TrackTime -> TrackTime -> TrackId -> m ()
move_track_events TrackTime
block_end TrackTime
start TrackTime
shift TrackId
track_id =
    forall (m :: * -> *). M m => TrackId -> (Events -> Events) -> m ()
Ui.modify_events TrackId
track_id forall a b. (a -> b) -> a -> b
$ \Events
events ->
        TrackTime -> TrackTime -> TrackTime -> Events -> Events
move_events TrackTime
block_end TrackTime
start TrackTime
shift Events
events

-- | All events starting at and after a point to the end are shifted by the
-- given amount.
move_events :: ScoreTime -- ^ events past the block end are shortened or removed
    -> ScoreTime -> ScoreTime -> Events.Events -> Events.Events
move_events :: TrackTime -> TrackTime -> TrackTime -> Events -> Events
move_events TrackTime
block_end TrackTime
point TrackTime
shift Events
events = Events
merged
    where
    shifted :: [Event]
shifted = Bool -> TrackTime -> [Event] -> [Event]
Events.clip_list Bool
False TrackTime
block_end forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (Lens Event TrackTime
Event.start_ forall f a. Lens f a -> (a -> a) -> f -> f
%= (forall a. Num a => a -> a -> a
+TrackTime
shift)) (TrackTime -> Events -> [Event]
Events.at_after TrackTime
point Events
events)
    -- +1 in case the last event is +0 duration.
    merged :: Events
merged = [Event] -> Events -> Events
Events.insert [Event]
shifted forall a b. (a -> b) -> a -> b
$
        Range -> Events -> Events
Events.remove (TrackTime -> TrackTime -> Range
Events.Range TrackTime
point (Events -> TrackTime
Events.time_end Events
events forall a. Num a => a -> a -> a
+ TrackTime
1)) Events
events

-- * replace tokens

data Replacement =
    RLiteral !Text -- ^ literal text
    | F !Int -- ^ field from match
    deriving (Replacement -> Replacement -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Replacement -> Replacement -> Bool
$c/= :: Replacement -> Replacement -> Bool
== :: Replacement -> Replacement -> Bool
$c== :: Replacement -> Replacement -> Bool
Eq, Int -> Replacement -> ShowS
[Replacement] -> ShowS
Replacement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Replacement] -> ShowS
$cshowList :: [Replacement] -> ShowS
show :: Replacement -> String
$cshow :: Replacement -> String
showsPrec :: Int -> Replacement -> ShowS
$cshowsPrec :: Int -> Replacement -> ShowS
Show)

instance String.IsString Replacement where
    fromString :: String -> Replacement
fromString = Token -> Replacement
RLiteral forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Token
txt

-- | Regex-like substitution on tracklang tokens.
--
-- Short names and IsString instances attempt to make it concise enough for
-- inline use.  If the pattern doesn't match, the input is returned unchanged.
substitute :: Parser -> [Replacement] -> Text -> Either Text Text
substitute :: Parser -> [Replacement] -> Token -> Either Token Token
substitute Parser
parser [Replacement]
replacements Token
text = case Maybe (IntMap Token)
match of
    Maybe (IntMap Token)
Nothing -> forall a b. b -> Either a b
Right Token
text
    Just IntMap Token
matches -> [Token] -> Token
Text.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Bool
Text.null) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IntMap Token -> Replacement -> Either Token Token
replace IntMap Token
matches) [Replacement]
replacements
    where
    match :: Maybe (IntMap Token)
match = forall a. [(Int, a)] -> IntMap a
IntMap.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser -> Token -> Maybe [Token]
parse_tokens Parser
parser Token
text
    replace :: IntMap Token -> Replacement -> Either Token Token
replace IntMap Token
matches Replacement
r = case Replacement
r of
        RLiteral Token
text -> forall a b. b -> Either a b
Right Token
text
        F Int
n -> forall err a. err -> Maybe a -> Either err a
justErr (Token
"no match for field " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Token
showt Int
n) forall a b. (a -> b) -> a -> b
$
            forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n IntMap Token
matches

-- ** parser

-- | Yet another \"list of successes\" style parser.
newtype Parser = Parser ([Token] -> [([Match], [Token])])
type Token = Text
type Match = [Token]

parse_tokens :: Parser -> Text -> Maybe [Text]
parse_tokens :: Parser -> Token -> Maybe [Token]
parse_tokens Parser
parser =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map [Token] -> Token
Text.unwords) 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
. Parser -> [Token] -> [[[Token]]]
parse Parser
parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Token -> Token
Text.strip
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> [Token]
Parse.lex

parse :: Parser -> [Token] -> [[Match]]
parse :: Parser -> [Token] -> [[[Token]]]
parse (Parser [Token] -> [([[Token]], [Token])]
p) = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> [([[Token]], [Token])]
p

instance Semigroup Parser where
    Parser [Token] -> [([[Token]], [Token])]
p1 <> :: Parser -> Parser -> Parser
<> Parser [Token] -> [([[Token]], [Token])]
p2 = ([Token] -> [([[Token]], [Token])]) -> Parser
Parser forall a b. (a -> b) -> a -> b
$ \[Token]
tokens -> do
        ([[Token]]
matches1, [Token]
rest1) <- [Token] -> [([[Token]], [Token])]
p1 [Token]
tokens
        ([[Token]]
matches2, [Token]
rest2) <- [Token] -> [([[Token]], [Token])]
p2 [Token]
rest1
        forall (m :: * -> *) a. Monad m => a -> m a
return ([[Token]]
matches1 forall a. [a] -> [a] -> [a]
++ [[Token]]
matches2, [Token]
rest2)
instance Monoid Parser where
    mempty :: Parser
mempty = ([Token] -> [([[Token]], [Token])]) -> Parser
Parser forall a b. (a -> b) -> a -> b
$ \[Token]
tokens -> [([], [Token]
tokens)]
    mappend :: Parser -> Parser -> Parser
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance String.IsString Parser where
    fromString :: String -> Parser
fromString = Token -> Parser
literal forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Token
txt

-- | Match a literal token.
literal :: Text -> Parser
literal :: Token -> Parser
literal Token
token = ([Token] -> [([[Token]], [Token])]) -> Parser
Parser forall a b. (a -> b) -> a -> b
$ \[Token]
tokens -> case [Token]
tokens of
    Token
t : [Token]
ts
        | Token
t forall a. Eq a => a -> a -> Bool
== Token
token -> [([], [Token]
ts)]
        | Bool
otherwise -> []
    [] -> []

-- | Match one token.
w :: Parser
w :: Parser
w = ([Token] -> [([[Token]], [Token])]) -> Parser
Parser forall a b. (a -> b) -> a -> b
$ \[Token]
tokens -> case [Token]
tokens of
    Token
t : [Token]
ts -> [([[Token
t]], [Token]
ts)]
    [] -> []

-- | Match 0 or more tokens.
ws :: Parser
ws :: Parser
ws = ([Token] -> [([[Token]], [Token])]) -> Parser
Parser forall a b. (a -> b) -> a -> b
$ \[Token]
tokens ->
    [([[Token]
pre], [Token]
post) | ([Token]
pre, [Token]
post) <- forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [([a], [a])]
splits [Token]
tokens]

-- | Match 1 or more tokens.
ws1 :: Parser
ws1 :: Parser
ws1 = ([Token] -> [([[Token]], [Token])]) -> Parser
Parser forall a b. (a -> b) -> a -> b
$ \[Token]
tokens ->
    [([[Token]
pre], [Token]
post) | ([Token]
pre, [Token]
post) <- forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [([a], [a])]
splits [Token]
tokens]

splits :: [a] -> [([a], [a])]
splits :: forall a. [a] -> [([a], [a])]
splits [a]
xs = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [[a]]
List.inits [a]
xs) (forall a. [a] -> [[a]]
List.tails [a]
xs)